From 6a3f3a62452670380827f9e39dd28c5092741099 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Feb 2018 17:45:44 +0100 Subject: Hook for MPPA_K1c (generates Risc-V code for now) --- mppa_k1c/Archi.v | 65 ++ mppa_k1c/Asm.v | 1172 +++++++++++++++++++++++++++++++++++ mppa_k1c/AsmToJSON.ml | 23 + mppa_k1c/Asmexpand.ml | 619 ++++++++++++++++++ mppa_k1c/Asmgen.v | 936 ++++++++++++++++++++++++++++ mppa_k1c/Asmgenproof.v | 1028 ++++++++++++++++++++++++++++++ mppa_k1c/Asmgenproof1.v | 1411 ++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/CBuiltins.ml | 61 ++ mppa_k1c/CombineOp.v | 138 +++++ mppa_k1c/CombineOpproof.v | 173 ++++++ mppa_k1c/ConstpropOp.v | 613 ++++++++++++++++++ mppa_k1c/ConstpropOp.vp | 309 +++++++++ mppa_k1c/ConstpropOpproof.v | 745 ++++++++++++++++++++++ mppa_k1c/Conventions1.v | 441 +++++++++++++ mppa_k1c/Machregs.v | 253 ++++++++ mppa_k1c/Machregsaux.ml | 33 + mppa_k1c/Machregsaux.mli | 18 + mppa_k1c/NeedOp.v | 173 ++++++ mppa_k1c/Op.v | 1361 ++++++++++++++++++++++++++++++++++++++++ mppa_k1c/PrintOp.ml | 166 +++++ mppa_k1c/SelectLong.v | 778 +++++++++++++++++++++++ mppa_k1c/SelectLong.vp | 364 +++++++++++ mppa_k1c/SelectLongproof.v | 619 ++++++++++++++++++ mppa_k1c/SelectOp.v | 1219 ++++++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 450 ++++++++++++++ mppa_k1c/SelectOpproof.v | 925 +++++++++++++++++++++++++++ mppa_k1c/Stacklayout.v | 147 +++++ mppa_k1c/TargetPrinter.ml | 657 ++++++++++++++++++++ mppa_k1c/ValueAOp.v | 218 +++++++ mppa_k1c/extractionMachdep.v | 27 + 30 files changed, 15142 insertions(+) create mode 100644 mppa_k1c/Archi.v create mode 100644 mppa_k1c/Asm.v create mode 100644 mppa_k1c/AsmToJSON.ml create mode 100644 mppa_k1c/Asmexpand.ml create mode 100644 mppa_k1c/Asmgen.v create mode 100644 mppa_k1c/Asmgenproof.v create mode 100644 mppa_k1c/Asmgenproof1.v create mode 100644 mppa_k1c/CBuiltins.ml create mode 100644 mppa_k1c/CombineOp.v create mode 100644 mppa_k1c/CombineOpproof.v create mode 100644 mppa_k1c/ConstpropOp.v create mode 100644 mppa_k1c/ConstpropOp.vp create mode 100644 mppa_k1c/ConstpropOpproof.v create mode 100644 mppa_k1c/Conventions1.v create mode 100644 mppa_k1c/Machregs.v create mode 100644 mppa_k1c/Machregsaux.ml create mode 100644 mppa_k1c/Machregsaux.mli create mode 100644 mppa_k1c/NeedOp.v create mode 100644 mppa_k1c/Op.v create mode 100644 mppa_k1c/PrintOp.ml create mode 100644 mppa_k1c/SelectLong.v create mode 100644 mppa_k1c/SelectLong.vp create mode 100644 mppa_k1c/SelectLongproof.v create mode 100644 mppa_k1c/SelectOp.v create mode 100644 mppa_k1c/SelectOp.vp create mode 100644 mppa_k1c/SelectOpproof.v create mode 100644 mppa_k1c/Stacklayout.v create mode 100644 mppa_k1c/TargetPrinter.ml create mode 100644 mppa_k1c/ValueAOp.v create mode 100644 mppa_k1c/extractionMachdep.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v new file mode 100644 index 00000000..a1664262 --- /dev/null +++ b/mppa_k1c/Archi.v @@ -0,0 +1,65 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Jacques-Henri Jourdan, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Architecture-dependent parameters for RISC-V *) + +Require Import ZArith. +Require Import Fappli_IEEE. +Require Import Fappli_IEEE_bits. + +Parameter ptr64 : bool. + +Definition big_endian := false. + +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := negb ptr64. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong. destruct ptr64; simpl; congruence. +Qed. + +(** 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 + except the MSB, a.k.a. the quiet bit." + 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 choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := + false. (**r always choose first NaN *) + +Program Definition default_pl_32 : bool * nan_pl 24 := + (false, iter_nat 22 _ xO xH). + +Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := + false. (**r always choose first NaN *) + +Definition float_of_single_preserves_sNaN := false. + +Global Opaque ptr64 big_endian splitlong + default_pl_64 choose_binop_pl_64 + default_pl_32 choose_binop_pl_32 + float_of_single_preserves_sNaN. + +(** Whether to generate position-independent code or not *) + +Parameter pic_code: unit -> bool. diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v new file mode 100644 index 00000000..4cd3b1fd --- /dev/null +++ b/mppa_k1c/Asm.v @@ -0,0 +1,1172 @@ +(* *********************************************************************) +(* *) +(* 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 RISC-V assembly language. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. + +(** * Abstract syntax *) + +(** Integer registers. X0 is treated specially because it always reads + as zero and is never used as a destination of an instruction. *) + +Inductive ireg: Type := + | X1: ireg | X2: ireg | X3: ireg | X4: ireg | X5: ireg + | X6: ireg | X7: ireg | X8: ireg | X9: ireg | X10: ireg + | X11: ireg | X12: ireg | X13: ireg | X14: ireg | X15: ireg + | X16: ireg | X17: ireg | X18: ireg | X19: ireg | X20: ireg + | X21: ireg | X22: ireg | X23: ireg | X24: ireg | X25: ireg + | X26: ireg | X27: ireg | X28: ireg | X29: ireg | X30: ireg + | X31: ireg. + +Inductive ireg0: Type := + | X0: ireg0 | X: ireg -> ireg0. + +Coercion X: ireg >-> ireg0. + +(** Floating-point registers *) + +Inductive freg: Type := + | F0: freg | F1: freg | F2: freg | F3: freg + | F4: freg | F5: freg | F6: freg | F7: freg + | F8: freg | F9: freg | F10: freg | F11: freg + | F12: freg | F13: freg | F14: freg | F15: freg + | F16: freg | F17: freg | F18: freg | F19: freg + | F20: freg | F21: freg | F22: freg | F23: freg + | F24: freg | F25: freg | F26: freg | F27: freg + | F28: freg | F29: freg | F30: freg | F31: freg. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma ireg0_eq: forall (x y: ireg0), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** We model the following registers of the RISC-V architecture. *) + +Inductive preg: Type := + | IR: ireg -> preg (**r integer registers *) + | FR: freg -> preg (**r double-precision float registers *) + | PC: preg. (**r program counter *) + +Coercion IR: ireg >-> preg. +Coercion FR: freg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) + +Notation "'SP'" := X2 (only parsing) : asm. +Notation "'RA'" := X1 (only parsing) : asm. + +(** Offsets for load and store instructions. An offset is either an + immediate integer or the low part of a symbol. *) + +Inductive offset : Type := + | Ofsimm (ofs: ptrofs) + | Ofslow (id: ident) (ofs: ptrofs). + +(** The RISC-V instruction set is composed of several subsets. We model + the "32I" (32-bit integers), "64I" (64-bit integers), + "M" (multiplication and division), + "F" (single-precision floating-point) + and "D" (double-precision floating-point) subsets. + + For 32- and 64-bit integer arithmetic, the RISC-V instruction set comprises + generic integer operations such as ADD that operate over the full width + of an integer register (either 32 or 64 bit), plus specific instructions + such as ADDW that normalize their results to signed 32-bit integers. + Other instructions such as AND work equally well over 32- and 64-bit + integers, with the convention that 32-bit integers are represented + sign-extended in 64-bit registers. + + This clever design is challenging to formalize in the CompCert value + model. As a first step, we follow a more traditional approach, + also used in the x86 port, whereas we have two sets of (pseudo-) + instructions, one for 32-bit integer arithmetic, with suffix W, + the other for 64-bit integer arithmetic, with suffix L. The mapping + to actual instructions is done when printing assembly code, as follows: + - In 32-bit mode: + ADDW becomes ADD, ADDL is an error, ANDW becomes AND, ANDL is an error. + - In 64-bit mode: + ADDW becomes ADDW, ADDL becomes ADD, ANDW and ANDL both become AND. +*) + +Definition label := positive. + +(** A note on immediates: there are various constraints on immediate + operands to RISC-V 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 RISC-V generator (file + [Asmgen]) is careful to respect this range. *) + +Inductive instruction : Type := + | Pmv (rd: ireg) (rs: ireg) (**r integer move *) + +(** 32-bit integer register-immediate instructions *) + | Paddiw (rd: ireg) (rs: ireg0) (imm: int) (**r add immediate *) + | Psltiw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than immediate *) + | Psltiuw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than unsigned immediate *) + | Pandiw (rd: ireg) (rs: ireg0) (imm: int) (**r and immediate *) + | Poriw (rd: ireg) (rs: ireg0) (imm: int) (**r or immediate *) + | Pxoriw (rd: ireg) (rs: ireg0) (imm: int) (**r xor immediate *) + | Pslliw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) + | Psrliw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) + | Psraiw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) + | Pluiw (rd: ireg) (imm: int) (**r load upper-immediate *) +(** 32-bit integer register-register instructions *) + | Paddw (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) + | Psubw (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) + + | Pmulw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) + | Pmulhw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high signed *) + | Pmulhuw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high unsigned *) + | Pdivw (rd: ireg) (rs1 rs2: ireg0) (**r integer division *) + | Pdivuw (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer division *) + | Premw (rd: ireg) (rs1 rs2: ireg0) (**r integer remainder *) + | Premuw (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer remainder *) + | Psltw (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than *) + | Psltuw (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than unsigned *) + | Pseqw (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 == rs2] (pseudo) *) + | Psnew (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 != rs2] (pseudo) *) + | Pandw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise and *) + | Porw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise or *) + | Pxorw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise xor *) + | Psllw (rd: ireg) (rs1 rs2: ireg0) (**r shift-left-logical *) + | Psrlw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-logical *) + | Psraw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) + +(** 64-bit integer register-immediate instructions *) + | Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) + | Psltil (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than immediate *) + | Psltiul (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than unsigned immediate *) + | Pandil (rd: ireg) (rs: ireg0) (imm: int64) (**r and immediate *) + | Poril (rd: ireg) (rs: ireg0) (imm: int64) (**r or immediate *) + | Pxoril (rd: ireg) (rs: ireg0) (imm: int64) (**r xor immediate *) + | Psllil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) + | Psrlil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) + | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) + | Pluil (rd: ireg) (imm: int64) (**r load upper-immediate *) +(** 64-bit integer register-register instructions *) + | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) + | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) + + | Pmull (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) + | Pmulhl (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high signed *) + | Pmulhul (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high unsigned *) + | Pdivl (rd: ireg) (rs1 rs2: ireg0) (**r integer division *) + | Pdivul (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer division *) + | Preml (rd: ireg) (rs1 rs2: ireg0) (**r integer remainder *) + | Premul (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer remainder *) + | Psltl (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than *) + | Psltul (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than unsigned *) + | Pseql (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 == rs2] (pseudo) *) + | Psnel (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 != rs2] (pseudo) *) + | Pandl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise and *) + | Porl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise or *) + | Pxorl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise xor *) + | Pslll (rd: ireg) (rs1 rs2: ireg0) (**r shift-left-logical *) + | Psrll (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-logical *) + | Psral (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) + + | Pcvtl2w (rd: ireg) (rs: ireg0) (**r int64->int32 (pseudo) *) + | Pcvtw2l (r: ireg) (**r int32 signed -> int64 (pseudo) *) + + (* Unconditional jumps. Links are always to X1/RA. *) + | Pj_l (l: label) (**r jump to label *) + | Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) + | Pj_r (r: ireg) (sg: signature) (**r jump register *) + | Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) + | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) + + (* Conditional branches, 32-bit comparisons *) + | Pbeqw (rs1 rs2: ireg0) (l: label) (**r branch-if-equal *) + | Pbnew (rs1 rs2: ireg0) (l: label) (**r branch-if-not-equal signed *) + | Pbltw (rs1 rs2: ireg0) (l: label) (**r branch-if-less signed *) + | Pbltuw (rs1 rs2: ireg0) (l: label) (**r branch-if-less unsigned *) + | Pbgew (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal signed *) + | Pbgeuw (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal unsigned *) + + (* Conditional branches, 64-bit comparisons *) + | Pbeql (rs1 rs2: ireg0) (l: label) (**r branch-if-equal *) + | Pbnel (rs1 rs2: ireg0) (l: label) (**r branch-if-not-equal signed *) + | Pbltl (rs1 rs2: ireg0) (l: label) (**r branch-if-less signed *) + | Pbltul (rs1 rs2: ireg0) (l: label) (**r branch-if-less unsigned *) + | Pbgel (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal signed *) + | Pbgeul (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal unsigned *) + + (* Loads and stores *) + | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int8 *) + | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int8 *) + | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int16 *) + | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int16 *) + | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) + | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) + | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) + | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) + + | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) + | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store int16 *) + | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) + + (* Synchronization *) + | Pfence (**r fence *) + + (* floating point register move *) + | Pfmv (rd: freg) (rs: freg) (**r move *) + | Pfmvxs (rd: ireg) (rs: freg) (**r move FP single to integer register *) + | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) + + (* 32-bit (single-precision) floating point *) + | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) + | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) + + | Pfnegs (rd: freg) (rs: freg) (**r negation *) + | Pfabss (rd: freg) (rs: freg) (**r absolute value *) + + | Pfadds (rd: freg) (rs1 rs2: freg) (**r addition *) + | Pfsubs (rd: freg) (rs1 rs2: freg) (**r subtraction *) + | Pfmuls (rd: freg) (rs1 rs2: freg) (**r multiplication *) + | Pfdivs (rd: freg) (rs1 rs2: freg) (**r division *) + | Pfmins (rd: freg) (rs1 rs2: freg) (**r minimum *) + | Pfmaxs (rd: freg) (rs1 rs2: freg) (**r maximum *) + + | Pfeqs (rd: ireg) (rs1 rs2: freg) (**r compare equal *) + | Pflts (rd: ireg) (rs1 rs2: freg) (**r compare less-than *) + | Pfles (rd: ireg) (rs1 rs2: freg) (**r compare less-than/equal *) + + | Pfsqrts (rd: freg) (rs: freg) (**r square-root *) + + | Pfmadds (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-add *) + | Pfmsubs (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-sub *) + | Pfnmadds (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-add *) + | Pfnmsubs (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-sub *) + + | Pfcvtws (rd: ireg) (rs: freg) (**r float32 -> int32 conversion *) + | Pfcvtwus (rd: ireg) (rs: freg) (**r float32 -> unsigned int32 conversion *) + | Pfcvtsw (rd: freg) (rs: ireg0) (**r int32 -> float32 conversion *) + | Pfcvtswu (rd: freg) (rs: ireg0) (**r unsigned int32 -> float32 conversion *) + + | Pfcvtls (rd: ireg) (rs: freg) (**r float32 -> int64 conversion *) + | Pfcvtlus (rd: ireg) (rs: freg) (**r float32 -> unsigned int64 conversion *) + | Pfcvtsl (rd: freg) (rs: ireg0) (**r int64 -> float32 conversion *) + | Pfcvtslu (rd: freg) (rs: ireg0) (**r unsigned int 64-> float32 conversion *) + + (* 64-bit (double-precision) floating point *) + | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) + | Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) + | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) + | Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) + + | Pfnegd (rd: freg) (rs: freg) (**r negation *) + | Pfabsd (rd: freg) (rs: freg) (**r absolute value *) + + | Pfaddd (rd: freg) (rs1 rs2: freg) (**r addition *) + | Pfsubd (rd: freg) (rs1 rs2: freg) (**r subtraction *) + | Pfmuld (rd: freg) (rs1 rs2: freg) (**r multiplication *) + | Pfdivd (rd: freg) (rs1 rs2: freg) (**r division *) + | Pfmind (rd: freg) (rs1 rs2: freg) (**r minimum *) + | Pfmaxd (rd: freg) (rs1 rs2: freg) (**r maximum *) + + | Pfeqd (rd: ireg) (rs1 rs2: freg) (**r compare equal *) + | Pfltd (rd: ireg) (rs1 rs2: freg) (**r compare less-than *) + | Pfled (rd: ireg) (rs1 rs2: freg) (**r compare less-than/equal *) + + | Pfsqrtd (rd: freg) (rs: freg) (**r square-root *) + + | Pfmaddd (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-add *) + | Pfmsubd (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-sub *) + | Pfnmaddd (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-add *) + | Pfnmsubd (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-sub *) + + | Pfcvtwd (rd: ireg) (rs: freg) (**r float -> int32 conversion *) + | Pfcvtwud (rd: ireg) (rs: freg) (**r float -> unsigned int32 conversion *) + | Pfcvtdw (rd: freg) (rs: ireg0) (**r int32 -> float conversion *) + | Pfcvtdwu (rd: freg) (rs: ireg0) (**r unsigned int32 -> float conversion *) + + | Pfcvtld (rd: ireg) (rs: freg) (**r float -> int64 conversion *) + | Pfcvtlud (rd: ireg) (rs: freg) (**r float -> unsigned int64 conversion *) + | Pfcvtdl (rd: freg) (rs: ireg0) (**r int64 -> float conversion *) + | Pfcvtdlu (rd: freg) (rs: ireg0) (**r unsigned int64 -> float conversion *) + + | Pfcvtds (rd: freg) (rs: freg) (**r float32 -> float *) + | Pfcvtsd (rd: freg) (rs: freg) (**r float -> float32 *) + + (* 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 *) + | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) + | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) + | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) + + +(** The pseudo-instructions are the following: + +- [Plabel]: define a code label at the current program point. + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Ploadli rd ival]: load an immediate 64-bit integer into an integer + register rd. Expands to a load from an address in the constant data section, + using the integer register x31 as temporary: +<< + lui x31, %hi(lbl) + ld rd, %lo(lbl)(x31) +lbl: + .quad ival +>> + +- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval + into a float register rd. + +- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval + into a float register rd. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. + +- [Pseq rd rs1 rs2]: since unsigned comparisons have particular + semantics for pointers, we cannot encode equality directly using + xor/sub etc, which have only integer semantics. +<< + xor rd, rs1, rs2 + sltiu rd, rd, 1 +>> + The [xor] is omitted if one of [rs1] and [rs2] is [x0]. + +- [Psne rd rs1 rs2]: similarly for unsigned inequality. +<< + xor rd, rs1, rs2 + sltu rd, x0, rd +>> +*) + +Definition code := list instruction. +Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain + the convention that integer registers are mapped to values of + type [Tint] or [Tlong] (in 64 bit mode), + and float registers to values of type [Tsingle] or [Tfloat]. *) + +Definition regset := Pregmap.t val. +Definition genv := Genv.t fundef unit. + +Definition get0w (rs: regset) (r: ireg0) : val := + match r with + | X0 => Vint Int.zero + | X r => rs r + end. + +Definition get0l (rs: regset) (r: ireg0) : val := + match r with + | X0 => Vlong Int64.zero + | X r => rs r + end. + +Notation "a # b" := (a b) (at level 1, only parsing) : asm. +Notation "a ## b" := (get0w a b) (at level 1) : asm. +Notation "a ### b" := (get0l a b) (at level 1) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + +(** Undefining some registers *) + +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <- Vundef) + end. + +(** Assigning a register pair *) + +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + +(** Assigning multiple registers *) + +Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := + match rl, vl with + | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) + | _, _ => rs + end. + +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + +Section RELSEM. + +(** Looking up instructions in a code sequence by position. *) + +Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := + match c with + | nil => None + | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il + end. + +(** Position corresponding to a label *) + +Definition is_label (lbl: label) (instr: instruction) : bool := + match instr with + | Plabel lbl' => if peq lbl lbl' then true else false + | _ => false + end. + +Lemma is_label_correct: + forall lbl instr, + if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. +Proof. + intros. destruct instr; simpl; try discriminate. + case (peq lbl lbl0); intro; congruence. +Qed. + +Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' + end. + +Variable ge: genv. + +(** The two functions below axiomatize how the linker processes + symbolic references [symbol + offset)] and splits their + actual values into a 20-bit high part [%hi(symbol + offset)] and + a 12-bit low part [%lo(symbol + offset)]. *) + +Parameter low_half: genv -> ident -> ptrofs -> ptrofs. +Parameter high_half: genv -> ident -> ptrofs -> val. + +(** The fundamental property of these operations is that, when applied + to the address of a symbol, their results can be recombined by + addition, rebuilding the original address. *) + +Axiom low_high_half: + forall id ofs, + Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. + +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [Next rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Stuck] if the processor is stuck. *) + +Inductive outcome: Type := + | Next: regset -> mem -> outcome + | Stuck: outcome. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextinstr]) or branching to a label ([goto_label]). *) + +Definition nextinstr (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := + match label_pos lbl 0 (fn_code f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end + end. + +(** Auxiliaries for memory accesses *) + +Definition eval_offset (ofs: offset) : ptrofs := + match ofs with + | Ofsimm n => n + | Ofslow id delta => low_half ge id delta + end. + +Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) + (d: preg) (a: ireg) (ofs: offset) := + match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with + | None => Stuck + | Some v => Next (nextinstr (rs#d <- v)) m + end. + +Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) + (s: preg) (a: ireg) (ofs: offset) := + match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with + | None => Stuck + | Some m' => Next (nextinstr rs) m' + end. + +(** Evaluating a branch *) + +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := + match res with + | Some true => goto_label f l rs m + | Some false => Next (nextinstr rs) m + | None => Stuck + end. + +(** Execution of a single instruction [i] in initial state [rs] and + [m]. Return updated state. For instructions that correspond to + actual 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. + + 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 exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := + match i with + | Pmv d s => + Next (nextinstr (rs#d <- (rs#s))) m + +(** 32-bit integer register-immediate instructions *) + | Paddiw d s i => + Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m + | Psltiw d s i => + Next (nextinstr (rs#d <- (Val.cmp Clt rs##s (Vint i)))) m + | Psltiuw d s i => + Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Clt rs##s (Vint i)))) m + | Pandiw d s i => + Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m + | Poriw d s i => + Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m + | Pxoriw d s i => + Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m + | Pslliw d s i => + Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m + | Psrliw d s i => + Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m + | Psraiw d s i => + Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m + | Pluiw d i => + Next (nextinstr (rs#d <- (Vint (Int.shl i (Int.repr 12))))) m + +(** 32-bit integer register-register instructions *) + | Paddw d s1 s2 => + Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m + | Psubw d s1 s2 => + Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m + | Pmulw d s1 s2 => + Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m + | Pmulhw d s1 s2 => + Next (nextinstr (rs#d <- (Val.mulhs rs##s1 rs##s2))) m + | Pmulhuw d s1 s2 => + Next (nextinstr (rs#d <- (Val.mulhu rs##s1 rs##s2))) m + | Pdivw d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.divs rs##s1 rs##s2)))) m + | Pdivuw d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.divu rs##s1 rs##s2)))) m + | Premw d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.mods rs##s1 rs##s2)))) m + | Premuw d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.modu rs##s1 rs##s2)))) m + | Psltw d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmp Clt rs##s1 rs##s2))) m + | Psltuw d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Clt rs##s1 rs##s2))) m + | Pseqw d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Ceq rs##s1 rs##s2))) m + | Psnew d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Cne rs##s1 rs##s2))) m + | Pandw d s1 s2 => + Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m + | Porw d s1 s2 => + Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m + | Pxorw d s1 s2 => + Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m + | Psllw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m + | Psrlw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m + | Psraw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m + +(** 64-bit integer register-immediate instructions *) + | Paddil d s i => + Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m + | Psltil d s i => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmpl Clt rs###s (Vlong i))))) m + | Psltiul d s i => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt rs###s (Vlong i))))) m + | Pandil d s i => + Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m + | Poril d s i => + Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m + | Pxoril d s i => + Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m + | Psllil d s i => + Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m + | Psrlil d s i => + Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m + | Psrail d s i => + Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m + | Pluil d i => + Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m + +(** 64-bit integer register-register instructions *) + | Paddl d s1 s2 => + Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m + | Psubl d s1 s2 => + Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m + | Pmull d s1 s2 => + Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m + | Pmulhl d s1 s2 => + Next (nextinstr (rs#d <- (Val.mullhs rs###s1 rs###s2))) m + | Pmulhul d s1 s2 => + Next (nextinstr (rs#d <- (Val.mullhu rs###s1 rs###s2))) m + | Pdivl d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.divls rs###s1 rs###s2)))) m + | Pdivul d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.divlu rs###s1 rs###s2)))) m + | Preml d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.modls rs###s1 rs###s2)))) m + | Premul d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.modlu rs###s1 rs###s2)))) m + | Psltl d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmpl Clt rs###s1 rs###s2)))) m + | Psltul d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt rs###s1 rs###s2)))) m + | Pseql d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq rs###s1 rs###s2)))) m + | Psnel d s1 s2 => + Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cne rs###s1 rs###s2)))) m + | Pandl d s1 s2 => + Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m + | Porl d s1 s2 => + Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m + | Pxorl d s1 s2 => + Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m + | Pslll d s1 s2 => + Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m + | Psrll d s1 s2 => + Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m + | Psral d s1 s2 => + Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m + + | Pcvtl2w d s => + Next (nextinstr (rs#d <- (Val.loword rs##s))) m + | Pcvtw2l r => + Next (nextinstr (rs#r <- (Val.longofint rs#r))) m + +(** Unconditional jumps. Links are always to X1/RA. *) + | Pj_l l => + goto_label f l rs m + | Pj_s s sg => + Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + | Pj_r r sg => + Next (rs#PC <- (rs#r)) m + | Pjal_s s sg => + Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero) + #RA <- (Val.offset_ptr rs#PC Ptrofs.one) + ) m + | Pjal_r r sg => + Next (rs#PC <- (rs#r) + #RA <- (Val.offset_ptr rs#PC Ptrofs.one) + ) m +(** Conditional branches, 32-bit comparisons *) + | Pbeqw s1 s2 l => + eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Ceq rs##s1 rs##s2) + | Pbnew s1 s2 l => + eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Cne rs##s1 rs##s2) + | Pbltw s1 s2 l => + eval_branch f l rs m (Val.cmp_bool Clt rs##s1 rs##s2) + | Pbltuw s1 s2 l => + eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##s1 rs##s2) + | Pbgew s1 s2 l => + eval_branch f l rs m (Val.cmp_bool Cge rs##s1 rs##s2) + | Pbgeuw s1 s2 l => + eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Cge rs##s1 rs##s2) + +(** Conditional branches, 64-bit comparisons *) + | Pbeql s1 s2 l => + eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Ceq rs###s1 rs###s2) + | Pbnel s1 s2 l => + eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Cne rs###s1 rs###s2) + | Pbltl s1 s2 l => + eval_branch f l rs m (Val.cmpl_bool Clt rs###s1 rs###s2) + | Pbltul s1 s2 l => + eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###s1 rs###s2) + | Pbgel s1 s2 l => + eval_branch f l rs m (Val.cmpl_bool Cge rs###s1 rs###s2) + | Pbgeul s1 s2 l => + eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Cge rs###s1 rs###s2) + +(** Loads and stores *) + | Plb d a ofs => + exec_load Mint8signed rs m d a ofs + | Plbu d a ofs => + exec_load Mint8unsigned rs m d a ofs + | Plh d a ofs => + exec_load Mint16signed rs m d a ofs + | Plhu d a ofs => + exec_load Mint16unsigned rs m d a ofs + | Plw d a ofs => + exec_load Mint32 rs m d a ofs + | Plw_a d a ofs => + exec_load Many32 rs m d a ofs + | Pld d a ofs => + exec_load Mint64 rs m d a ofs + | Pld_a d a ofs => + exec_load Many64 rs m d a ofs + | Psb s a ofs => + exec_store Mint8unsigned rs m s a ofs + | Psh s a ofs => + exec_store Mint16unsigned rs m s a ofs + | Psw s a ofs => + exec_store Mint32 rs m s a ofs + | Psw_a s a ofs => + exec_store Many32 rs m s a ofs + | Psd s a ofs => + exec_store Mint64 rs m s a ofs + | Psd_a s a ofs => + exec_store Many64 rs m s a ofs + +(** Floating point register move *) + | Pfmv d s => + Next (nextinstr (rs#d <- (rs#s))) m + +(** 32-bit (single-precision) floating point *) + | Pfls d a ofs => + exec_load Mfloat32 rs m d a ofs + | Pfss s a ofs => + exec_store Mfloat32 rs m s a ofs + + | Pfnegs d s => + Next (nextinstr (rs#d <- (Val.negfs rs#s))) m + | Pfabss d s => + Next (nextinstr (rs#d <- (Val.absfs rs#s))) m + + | Pfadds d s1 s2 => + Next (nextinstr (rs#d <- (Val.addfs rs#s1 rs#s2))) m + | Pfsubs d s1 s2 => + Next (nextinstr (rs#d <- (Val.subfs rs#s1 rs#s2))) m + | Pfmuls d s1 s2 => + Next (nextinstr (rs#d <- (Val.mulfs rs#s1 rs#s2))) m + | Pfdivs d s1 s2 => + Next (nextinstr (rs#d <- (Val.divfs rs#s1 rs#s2))) m + | Pfeqs d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpfs Ceq rs#s1 rs#s2))) m + | Pflts d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpfs Clt rs#s1 rs#s2))) m + | Pfles d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpfs Cle rs#s1 rs#s2))) m + + | Pfcvtws d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.intofsingle rs#s)))) m + | Pfcvtwus d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.intuofsingle rs#s)))) m + | Pfcvtsw d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofint rs##s)))) m + | Pfcvtswu d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofintu rs##s)))) m + + | Pfcvtls d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.longofsingle rs#s)))) m + | Pfcvtlus d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.longuofsingle rs#s)))) m + | Pfcvtsl d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflong rs###s)))) m + | Pfcvtslu d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflongu rs###s)))) m + +(** 64-bit (double-precision) floating point *) + | Pfld d a ofs => + exec_load Mfloat64 rs m d a ofs + | Pfld_a d a ofs => + exec_load Many64 rs m d a ofs + | Pfsd s a ofs => + exec_store Mfloat64 rs m s a ofs + | Pfsd_a s a ofs => + exec_store Many64 rs m s a ofs + + | Pfnegd d s => + Next (nextinstr (rs#d <- (Val.negf rs#s))) m + | Pfabsd d s => + Next (nextinstr (rs#d <- (Val.absf rs#s))) m + + | Pfaddd d s1 s2 => + Next (nextinstr (rs#d <- (Val.addf rs#s1 rs#s2))) m + | Pfsubd d s1 s2 => + Next (nextinstr (rs#d <- (Val.subf rs#s1 rs#s2))) m + | Pfmuld d s1 s2 => + Next (nextinstr (rs#d <- (Val.mulf rs#s1 rs#s2))) m + | Pfdivd d s1 s2 => + Next (nextinstr (rs#d <- (Val.divf rs#s1 rs#s2))) m + | Pfeqd d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpf Ceq rs#s1 rs#s2))) m + | Pfltd d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpf Clt rs#s1 rs#s2))) m + | Pfled d s1 s2 => + Next (nextinstr (rs#d <- (Val.cmpf Cle rs#s1 rs#s2))) m + + | Pfcvtwd d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.intoffloat rs#s)))) m + | Pfcvtwud d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.intuoffloat rs#s)))) m + | Pfcvtdw d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofint rs##s)))) m + | Pfcvtdwu d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofintu rs##s)))) m + + | Pfcvtld d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.longoffloat rs#s)))) m + | Pfcvtlud d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.longuoffloat rs#s)))) m + | Pfcvtdl d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflong rs###s)))) m + | Pfcvtdlu d s => + Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflongu rs###s)))) m + + | Pfcvtds d s => + Next (nextinstr (rs#d <- (Val.floatofsingle rs#s))) m + | Pfcvtsd d s => + Next (nextinstr (rs#d <- (Val.singleoffloat rs#s))) m + +(** Pseudo-instructions *) + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with + | None => Stuck + | Some m2 => Next (nextinstr (rs #X30 <- (rs SP) #SP <- sp #X31 <- Vundef)) m2 + end + | Pfreeframe sz pos => + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (nextinstr (rs#SP <- v #X31 <- Vundef)) m' + end + | _ => Stuck + end + end + | Plabel lbl => + Next (nextinstr rs) m + | Ploadsymbol rd s ofs => + Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m + | Ploadsymbol_high rd s ofs => + Next (nextinstr (rs#rd <- (high_half ge s ofs))) m + | Ploadli rd i => + Next (nextinstr (rs#X31 <- Vundef #rd <- (Vlong i))) m + | Ploadfi rd f => + Next (nextinstr (rs#X31 <- Vundef #rd <- (Vfloat f))) m + | Ploadsi rd f => + Next (nextinstr (rs#X31 <- Vundef #rd <- (Vsingle f))) m + | Pbtbl r tbl => + match rs r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => goto_label f lbl (rs#X5 <- Vundef #X31 <- Vundef) m + end + | _ => Stuck + end + | Pbuiltin ef args res => + Stuck (**r treated specially below *) + + (** The following instructions and directives are not generated directly by Asmgen, + so we do not model them. *) + | Pfence + + | Pfmvxs _ _ + | Pfmvxd _ _ + + | Pfmins _ _ _ + | Pfmaxs _ _ _ + | Pfsqrts _ _ + | Pfmadds _ _ _ _ + | Pfmsubs _ _ _ _ + | Pfnmadds _ _ _ _ + | Pfnmsubs _ _ _ _ + + | Pfmind _ _ _ + | Pfmaxd _ _ _ + | Pfsqrtd _ _ + | Pfmaddd _ _ _ _ + | Pfmsubd _ _ _ _ + | Pfnmaddd _ _ _ _ + | Pfnmsubd _ _ _ _ + => Stuck + end. + +(** Translation of the LTL/Linear/Mach view of machine registers to + the RISC-V view. Note that no LTL register maps to [X31]. This + register is reserved as temporary, to be used by the generated RV32G + code. *) + +Definition preg_of (r: mreg) : preg := + match r with + | R5 => X5 | R6 => X6 | R7 => X7 + | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11 + | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15 + | R16 => X16 | R17 => X17 | R18 => X18 | R19 => X19 + | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23 + | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27 + | R28 => X28 | R29 => X29 | R30 => X30 + + | Machregs.F0 => F0 | Machregs.F1 => F1 | Machregs.F2 => F2 | Machregs.F3 => F3 + | Machregs.F4 => F4 | Machregs.F5 => F5 | Machregs.F6 => F6 | Machregs.F7 => F7 + | Machregs.F8 => F8 | Machregs.F9 => F9 | Machregs.F10 => F10 | Machregs.F11 => F11 + | Machregs.F12 => F12 | Machregs.F13 => F13 | Machregs.F14 => F14 | Machregs.F15 => F15 + | Machregs.F16 => F16 | Machregs.F17 => F17 | Machregs.F18 => F18 | Machregs.F19 => F19 + | Machregs.F20 => F20 | Machregs.F21 => F21 | Machregs.F22 => F22 | Machregs.F23 => F23 + | Machregs.F24 => F24 | Machregs.F25 => F25 | Machregs.F26 => F26 | Machregs.F27 => F27 + | Machregs.F28 => F28 | Machregs.F29 => F29 | Machregs.F30 => F30 | Machregs.F31 => F31 + end. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use RISC-V registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + +(** Execution of the instruction at [rs PC]. *) + +Inductive state: Type := + | State: regset -> mem -> state. + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f i rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> + exec_instr f i rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextinstr + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#X31 <- Vundef))) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> + step (State rs m) t (State rs' m'). + +End RELSEM. + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <- Vnullptr + # RA <- Vnullptr in + Genv.init_mem p = Some m0 -> + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs PC = Vnullptr -> + rs X10 = Vint r -> + final_state (State rs m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +(** Determinacy of the [Asm] semantics. *) + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + split. constructor. auto. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. + +(** Classification functions for processor registers (used in Asmgenproof). *) + +Definition data_preg (r: preg) : bool := + match r with + | IR RA => false + | IR X31 => false + | IR _ => true + | FR _ => true + | PC => false + end. diff --git a/mppa_k1c/AsmToJSON.ml b/mppa_k1c/AsmToJSON.ml new file mode 100644 index 00000000..8a6a97a7 --- /dev/null +++ b/mppa_k1c/AsmToJSON.ml @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +(* Simple functions to serialize RISC-V Asm to JSON *) + +(* Dummy function *) +let destination: string option ref = ref None + +let sdump_folder = ref "" + +let print_if prog sourcename = + () + +let pp_mnemonics pp = () diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml new file mode 100644 index 00000000..945974e0 --- /dev/null +++ b/mppa_k1c/Asmexpand.ml @@ -0,0 +1,619 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Expanding built-ins and some pseudo-instructions by rewriting + of the RISC-V assembly code. *) + +open Asm +open Asmexpandaux +open AST +open Camlcoq +open Integers + +exception Error of string + +(* Useful constants and helper functions *) + +let _0 = Integers.Int.zero +let _1 = Integers.Int.one +let _2 = coqint_of_camlint 2l +let _4 = coqint_of_camlint 4l +let _8 = coqint_of_camlint 8l +let _16 = coqint_of_camlint 16l +let _m1 = coqint_of_camlint (-1l) + +let wordsize = if Archi.ptr64 then 8 else 4 + +let align n a = (n + a - 1) land (-a) + +(* Emit instruction sequences that set or offset a register by a constant. *) + +let expand_loadimm32 dst n = + List.iter emit (Asmgen.loadimm32 dst n []) +let expand_addptrofs dst src n = + List.iter emit (Asmgen.addptrofs dst src n []) +let expand_storeind_ptr src base ofs = + List.iter emit (Asmgen.storeind_ptr src base ofs []) + +(* Built-ins. They come in two flavors: + - annotation statements: take their arguments in registers or stack + locations; generate no code; + - inlined by the compiler: take their arguments in arbitrary + registers. +*) + +(* Fix-up code around calls to variadic functions. Floating-point arguments + residing in FP registers need to be moved to integer registers. *) + +let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |] +let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] + +let rec fixup_variadic_call pos tyl = + if pos < 8 then + match tyl with + | [] -> + () + | (Tint | Tany32) :: tyl -> + fixup_variadic_call (pos + 1) tyl + | Tsingle :: tyl -> + let rs =float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxs(rd, rs)); + fixup_variadic_call (pos + 1) tyl + | Tlong :: tyl -> + let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in + fixup_variadic_call pos' tyl + | (Tfloat | Tany64) :: tyl -> + if Archi.ptr64 then begin + let rs = float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxd(rd, rs)); + fixup_variadic_call (pos + 1) tyl + end else begin + let pos = align pos 2 in + if pos < 8 then begin + let rs = float_param_regs.(pos) + and rd1 = int_param_regs.(pos) + and rd2 = int_param_regs.(pos + 1) in + emit (Paddiw(X2, X X2, Integers.Int.neg _16)); + emit (Pfsd(rs, X2, Ofsimm _0)); + emit (Plw(rd1, X2, Ofsimm _0)); + emit (Plw(rd2, X2, Ofsimm _4)); + emit (Paddiw(X2, X X2, _16)); + fixup_variadic_call (pos + 2) tyl + end + end + +let fixup_call sg = + if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args + +(* Handling of annotations *) + +let expand_annot_val kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); + match args, res with + | [BA(IR src)], BR(IR dst) -> + if dst <> src then emit (Pmv (dst, src)) + | [BA(FR src)], BR(FR dst) -> + if dst <> src then emit (Pfmv (dst, src)) + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") + +(* Handling of memcpy *) + +(* Unaligned accesses are slow on RISC-V, so don't use them *) + +let offset_in_range ofs = + let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L + +let memcpy_small_arg sz arg tmp = + match arg with + | BA (IR r) -> + (r, _0) + | BA_addrstack ofs -> + if offset_in_range ofs + && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) + then (X2, ofs) + else begin expand_addptrofs tmp X2 ofs; (tmp, _0) end + | _ -> + assert false + +let expand_builtin_memcpy_small sz al src dst = + let (tsrc, tdst) = + if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in + let (rsrc, osrc) = memcpy_small_arg sz src tsrc in + let (rdst, odst) = memcpy_small_arg sz dst tdst in + let rec copy osrc odst sz = + if sz >= 8 && al >= 8 then + begin + emit (Pfld (F0, rsrc, Ofsimm osrc)); + emit (Pfsd (F0, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _8) (Ptrofs.add odst _8) (sz - 8) + end + else if sz >= 4 && al >= 4 then + begin + emit (Plw (X31, rsrc, Ofsimm osrc)); + emit (Psw (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _4) (Ptrofs.add odst _4) (sz - 4) + end + else if sz >= 2 && al >= 2 then + begin + emit (Plh (X31, rsrc, Ofsimm osrc)); + emit (Psh (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _2) (Ptrofs.add odst _2) (sz - 2) + end + else if sz >= 1 then + begin + emit (Plb (X31, rsrc, Ofsimm osrc)); + emit (Psb (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1) + end + in copy osrc odst sz + +let memcpy_big_arg sz arg tmp = + match arg with + | BA (IR r) -> if r <> tmp then emit (Pmv(tmp, r)) + | BA_addrstack ofs -> + expand_addptrofs tmp X2 ofs + | _ -> + assert false + +let expand_builtin_memcpy_big sz al src dst = + assert (sz >= al); + assert (sz mod al = 0); + let (s, d) = + if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in + memcpy_big_arg sz src s; + memcpy_big_arg sz dst d; + (* Use X7 as loop count, X1 and F0 as ld/st temporaries. *) + let (load, store, chunksize) = + if al >= 8 then + (Pfld (F0, s, Ofsimm _0), Pfsd (F0, d, Ofsimm _0), 8) + else if al >= 4 then + (Plw (X31, s, Ofsimm _0), Psw (X31, d, Ofsimm _0), 4) + else if al = 2 then + (Plh (X31, s, Ofsimm _0), Psh (X31, d, Ofsimm _0), 2) + else + (Plb (X31, s, Ofsimm _0), Psb (X31, d, Ofsimm _0), 1) in + expand_loadimm32 X7 (Z.of_uint (sz / chunksize)); + let delta = Z.of_uint chunksize in + let lbl = new_label () in + emit (Plabel lbl); + emit load; + expand_addptrofs s s delta; + emit (Paddiw(X7, X X7, _m1)); + emit store; + expand_addptrofs d d delta; + emit (Pbnew (X X7, X0, lbl)) + +let expand_builtin_memcpy sz al args = + let (dst, src) = + match args with [d; s] -> (d, s) | _ -> assert false in + if sz <= 32 + then expand_builtin_memcpy_small sz al src dst + else expand_builtin_memcpy_big sz al src dst + +(* Handling of volatile reads and writes *) + +let expand_builtin_vload_common chunk base ofs res = + match chunk, res with + | Mint8unsigned, BR(IR res) -> + emit (Plbu (res, base, Ofsimm ofs)) + | Mint8signed, BR(IR res) -> + emit (Plb (res, base, Ofsimm ofs)) + | Mint16unsigned, BR(IR res) -> + emit (Plhu (res, base, Ofsimm ofs)) + | Mint16signed, BR(IR res) -> + emit (Plh (res, base, Ofsimm ofs)) + | Mint32, BR(IR res) -> + emit (Plw (res, base, Ofsimm ofs)) + | Mint64, BR(IR res) -> + emit (Pld (res, base, Ofsimm ofs)) + | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> + let ofs' = Ptrofs.add ofs _4 in + if base <> res2 then begin + emit (Plw (res2, base, Ofsimm ofs)); + emit (Plw (res1, base, Ofsimm ofs')) + end else begin + emit (Plw (res1, base, Ofsimm ofs')); + emit (Plw (res2, base, Ofsimm ofs)) + end + | Mfloat32, BR(FR res) -> + emit (Pfls (res, base, Ofsimm ofs)) + | Mfloat64, BR(FR res) -> + emit (Pfld (res, base, Ofsimm ofs)) + | _ -> + assert false + +let expand_builtin_vload chunk args res = + match args with + | [BA(IR addr)] -> + expand_builtin_vload_common chunk addr _0 res + | [BA_addrstack ofs] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk X2 ofs res + else begin + expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) + expand_builtin_vload_common chunk X31 _0 res + end + | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs))] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk addr ofs res + else begin + expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vload_common chunk X31 _0 res + end + | _ -> + assert false + +let expand_builtin_vstore_common chunk base ofs src = + match chunk, src with + | (Mint8signed | Mint8unsigned), BA(IR src) -> + emit (Psb (src, base, Ofsimm ofs)) + | (Mint16signed | Mint16unsigned), BA(IR src) -> + emit (Psh (src, base, Ofsimm ofs)) + | Mint32, BA(IR src) -> + emit (Psw (src, base, Ofsimm ofs)) + | Mint64, BA(IR src) -> + emit (Psd (src, base, Ofsimm ofs)) + | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> + let ofs' = Ptrofs.add ofs _4 in + emit (Psw (src2, base, Ofsimm ofs)); + emit (Psw (src1, base, Ofsimm ofs')) + | Mfloat32, BA(FR src) -> + emit (Pfss (src, base, Ofsimm ofs)) + | Mfloat64, BA(FR src) -> + emit (Pfsd (src, base, Ofsimm ofs)) + | _ -> + assert false + +let expand_builtin_vstore chunk args = + match args with + | [BA(IR addr); src] -> + expand_builtin_vstore_common chunk addr _0 src + | [BA_addrstack ofs; src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk X2 ofs src + else begin + expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) + expand_builtin_vstore_common chunk X31 _0 src + end + | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs)); src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk addr ofs src + else begin + expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vstore_common chunk X31 _0 src + end + | _ -> + assert false + +(* Handling of varargs *) + +(* Size in words of the arguments to a function. This includes both + arguments passed in registers and arguments passed on stack. *) + +let rec args_size sz = function + | [] -> sz + | (Tint | Tsingle | Tany32) :: l -> + args_size (sz + 1) l + | (Tlong | Tfloat | Tany64) :: l -> + args_size (if Archi.ptr64 then sz + 1 else align sz 2 + 2) l + +let arguments_size sg = + args_size 0 sg.sig_args + +let save_arguments first_reg base_ofs = + for i = first_reg to 7 do + expand_storeind_ptr + int_param_regs.(i) + X2 + (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))) + done + +let vararg_start_ofs : Z.t option ref = ref None + +let expand_builtin_va_start r = + match !vararg_start_ofs with + | None -> + invalid_arg "Fatal error: va_start used in non-vararg function" + | Some ofs -> + expand_addptrofs X31 X2 (Ptrofs.repr ofs); + expand_storeind_ptr X31 r Ptrofs.zero + +(* Auxiliary for 64-bit integer arithmetic built-ins. They expand to + two instructions, one computing the low 32 bits of the result, + followed by another computing the high 32 bits. In cases where + the first instruction would overwrite arguments to the second + instruction, we must go through X31 to hold the low 32 bits of the result. +*) + +let expand_int64_arith conflict rl fn = + if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl + +(* Byte swaps. There are no specific instructions, so we use standard, + not-very-efficient formulas. *) + +let expand_bswap16 d s = + (* 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)) + +let expand_bswap32 d s = + (* 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 = + (* d = s << 56 + | (((s >> 8) & 0xFF) << 48) + | (((s >> 16) & 0xFF) << 40) + | (((s >> 24) & 0xFF) << 32) + | (((s >> 32) & 0xFF) << 24) + | (((s >> 40) & 0xFF) << 16) + | (((s >> 48) & 0xFF) << 8) + | s >> 56 *) + emit (Psllil(X1, X s, coqint_of_camlint 56l)); + 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))) + [(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)) + +(* Handling of compiler-inlined builtins *) + +let expand_builtin_inline name args res = + match name, args, res with + (* Synchronization *) + | "__builtin_membar", [], _ -> + () + | "__builtin_fence", [], _ -> + emit Pfence + (* Vararg stuff *) + | "__builtin_va_start", [BA(IR a)], _ -> + expand_builtin_va_start a + (* Byte swaps *) + | "__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 a1)], BR(IR res) -> + expand_bswap64 res a1 + | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + assert (ah = X6 && al = X5 && rh = X5 && rl = X6); + expand_bswap32 X5 X5; + expand_bswap32 X6 X6 + (* Float arithmetic *) + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> + emit (Pfabsd(res, a1)) + | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + emit (Pfsqrtd(res, a1)) + | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfmaddd(res, a1, a2, a3)) + | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfmsubd(res, a1, a2, a3)) + | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfnmaddd(res, a1, a2, a3)) + | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + emit (Pfnmsubd(res, a1, a2, a3)) + | "__builtin_fmin", [BA(FR a1); BA(FR a2)], BR(FR res) -> + emit (Pfmind(res, a1, a2)) + | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) -> + emit (Pfmaxd(res, a1, a2)) + (* 64-bit integer arithmetic for a 32-bit platform *) + | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + expand_int64_arith (rl = ah) rl + (fun rl -> + emit (Psltuw (X1, X0, X al)); + emit (Psubw (rl, X0, X al)); + emit (Psubw (rh, X0, X ah)); + emit (Psubw (rh, X rh, X X1))) + | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + expand_int64_arith (rl = bl || rl = ah || rl = bh) rl + (fun rl -> + emit (Paddw (rl, X al, X bl)); + emit (Psltuw (X1, X rl, X bl)); + emit (Paddw (rh, X ah, X bh)); + emit (Paddw (rh, X rh, X X1))) + | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); + BA_splitlong(BA(IR bh), BA(IR bl))], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + expand_int64_arith (rl = ah || rl = bh) rl + (fun rl -> + emit (Psltuw (X1, X al, X bl)); + emit (Psubw (rl, X al, X bl)); + emit (Psubw (rh, X ah, X bh)); + emit (Psubw (rh, X rh, X X1))) + | "__builtin_mull", [BA(IR a); BA(IR b)], + BR_splitlong(BR(IR rh), BR(IR rl)) -> + expand_int64_arith (rl = a || rl = b) rl + (fun rl -> + emit (Pmulw (rl, X a, X b)); + emit (Pmulhuw (rh, X a, X b))) + + (* Catch-all *) + | _ -> + raise (Error ("unrecognized builtin " ^ name)) + +(* Expansion of instructions *) + +let expand_instruction instr = + match instr with + | Pallocframe (sz, ofs) -> + let sg = get_current_function_sig() in + emit (Pmv (X30, X2)); + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in + let full_sz = Z.add sz (Z.of_uint extra_sz) in + expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg full_sz)); + expand_storeind_ptr X30 X2 ofs; + let va_ofs = + Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in + vararg_start_ofs := Some va_ofs; + save_arguments n va_ofs + end else begin + expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg sz)); + expand_storeind_ptr X30 X2 ofs; + vararg_start_ofs := None + end + | Pfreeframe (sz, ofs) -> + let sg = get_current_function_sig() in + let extra_sz = + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + if n >= 8 then 0 else align 16 ((8 - n) * wordsize) + end else 0 in + expand_addptrofs X2 X2 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + + | Pseqw(rd, rs1, rs2) -> + (* emulate based on the fact that x == 0 iff x + (* emulate based on the fact that x != 0 iff 0 + (* emulate based on the fact that x == 0 iff x + (* emulate based on the fact that x != 0 iff 0 + assert Archi.ptr64; + emit (Paddiw(rd, rs, Int.zero)) (* 32-bit sign extension *) + | Pcvtw2l(r) -> + assert Archi.ptr64 + (* no-operation because the 32-bit integer was kept sign extended already *) + + | Pjal_r(r, sg) -> + fixup_call sg; emit instr + | Pjal_s(symb, sg) -> + fixup_call sg; emit instr + | Pj_r(r, sg) when r <> X1 -> + fixup_call sg; emit instr + | Pj_s(symb, sg) -> + fixup_call sg; emit instr + + | Pbuiltin (ef,args,res) -> + begin match ef with + | EF_builtin (name,sg) -> + expand_builtin_inline (camlstring_of_coqstring name) args res + | EF_vload chunk -> + expand_builtin_vload chunk args res + | EF_vstore chunk -> + expand_builtin_vstore chunk args + | EF_annot_val (kind,txt,targ) -> + expand_annot_val kind txt targ args res + | EF_memcpy(sz, al) -> + expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + emit instr + | _ -> + assert false + end + | _ -> + emit instr + +(* NOTE: Dwarf register maps for RV32G are not yet specified + officially. This is just a placeholder. *) +let int_reg_to_dwarf = function + | X1 -> 1 | X2 -> 2 | X3 -> 3 + | X4 -> 4 | X5 -> 5 | X6 -> 6 | X7 -> 7 + | X8 -> 8 | X9 -> 9 | X10 -> 10 | X11 -> 11 + | X12 -> 12 | X13 -> 13 | X14 -> 14 | X15 -> 15 + | X16 -> 16 | X17 -> 17 | X18 -> 18 | X19 -> 19 + | X20 -> 20 | X21 -> 21 | X22 -> 22 | X23 -> 23 + | X24 -> 24 | X25 -> 25 | X26 -> 26 | X27 -> 27 + | X28 -> 28 | X29 -> 29 | X30 -> 30 | X31 -> 31 + +let float_reg_to_dwarf = function + | F0 -> 32 | F1 -> 33 | F2 -> 34 | F3 -> 35 + | F4 -> 36 | F5 -> 37 | F6 -> 38 | F7 -> 39 + | F8 -> 40 | F9 -> 41 | F10 -> 42 | F11 -> 43 + | F12 -> 44 | F13 -> 45 | F14 -> 46 | F15 -> 47 + | F16 -> 48 | F17 -> 49 | F18 -> 50 | F19 -> 51 + | F20 -> 52 | F21 -> 53 | F22 -> 54 | F23 -> 55 + | F24 -> 56 | F25 -> 57 | F26 -> 58 | F27 -> 59 + | F28 -> 60 | F29 -> 61 | F30 -> 62 | F31 -> 63 + +let preg_to_dwarf = function + | IR r -> int_reg_to_dwarf r + | FR r -> float_reg_to_dwarf r + | _ -> assert false + +let expand_function id fn = + try + set_current_function fn; + if !Clflags.option_g then + expand_debug id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code + else + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) + +let expand_fundef id = function + | Internal f -> + begin match expand_function id f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) + +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v new file mode 100644 index 00000000..a704ed74 --- /dev/null +++ b/mppa_k1c/Asmgen.v @@ -0,0 +1,936 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Translation from Mach to RISC-V assembly language *) + +Require Archi. +Require Import Coqlib Errors. +Require Import AST Integers Floats Memdata. +Require Import Op Locations Mach Asm. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(** The code generation functions take advantage of several + characteristics of the [Mach] code generated by earlier passes of the + compiler, mostly that argument and result registers are of the correct + types. These properties are true by construction, but it's easier to + recheck them during code generation and fail if they do not hold. *) + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. + +(** 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) + | Imm32_pair (hi: int) (lo: int). + +Definition make_immed32 (val: int) := + let lo := Int.sign_ext 12 val in + if Int.eq val lo + then Imm32_single val + else Imm32_pair (Int.shru (Int.sub val lo) (Int.repr 12)) lo. +(* + let discr := Int.shr val (Int.repr 11) in + let hi := Int.shru val (Int.repr 12) in + if Int.eq discr Int.zero || Int.eq discr Int.mone + then Imm32_single val + else Imm32_pair (Int.add hi (Int.and discr Int.one)) (Int.sign_ext 12 val). +*) + +(** Likewise, for 64-bit integer constants. *) + +Inductive immed64 : Type := + | Imm64_single (imm: int64) + | Imm64_pair (hi: int64) (lo: int64) + | Imm64_large (imm: int64). + +Definition make_immed64 (val: int64) := + let lo := Int64.sign_ext 12 val in + if Int64.eq val lo then Imm64_single lo else + let hi := Int64.zero_ext 20 (Int64.shru (Int64.sub val lo) (Int64.repr 12)) in + if Int64.eq val (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) + then Imm64_pair hi lo + else Imm64_large val. + +(** 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 load_hilo32 (r: ireg) (hi lo: int) k := + if Int.eq lo Int.zero then Pluiw r hi :: k + else Pluiw r hi :: Paddiw r r lo :: k. + +Definition loadimm32 (r: ireg) (n: int) (k: code) := + match make_immed32 n with + | Imm32_single imm => Paddiw r X0 imm :: k + | Imm32_pair hi lo => load_hilo32 r hi lo k + end. + +Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) + (opimm: ireg -> ireg0 -> int -> instruction) + (rd rs: ireg) (n: int) (k: code) := + match make_immed32 n with + | Imm32_single imm => opimm rd rs imm :: k + | Imm32_pair hi lo => load_hilo32 X31 hi lo (op rd rs X31 :: k) + end. + +Definition addimm32 := opimm32 Paddw Paddiw. +Definition andimm32 := opimm32 Pandw Pandiw. +Definition orimm32 := opimm32 Porw Poriw. +Definition xorimm32 := opimm32 Pxorw Pxoriw. +Definition sltimm32 := opimm32 Psltw Psltiw. +Definition sltuimm32 := opimm32 Psltuw Psltiuw. + +Definition load_hilo64 (r: ireg) (hi lo: int64) k := + if Int64.eq lo Int64.zero then Pluil r hi :: k + else Pluil r hi :: Paddil r r lo :: k. + +Definition loadimm64 (r: ireg) (n: int64) (k: code) := + match make_immed64 n with + | Imm64_single imm => Paddil r X0 imm :: k + | Imm64_pair hi lo => load_hilo64 r hi lo k + | Imm64_large imm => Ploadli r imm :: k + end. + +Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) + (opimm: ireg -> ireg0 -> int64 -> instruction) + (rd rs: ireg) (n: int64) (k: code) := + match make_immed64 n with + | Imm64_single imm => opimm rd rs imm :: k + | Imm64_pair hi lo => load_hilo64 X31 hi lo (op rd rs X31 :: k) + | Imm64_large imm => Ploadli X31 imm :: op rd rs X31 :: k + end. + +Definition addimm64 := opimm64 Paddl Paddil. +Definition andimm64 := opimm64 Pandl Pandil. +Definition orimm64 := opimm64 Porl Poril. +Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. + +Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := + if Ptrofs.eq_dec n Ptrofs.zero then + Pmv rd rs :: k + else + if Archi.ptr64 + then addimm64 rd rs (Ptrofs.to_int64 n) k + else addimm32 rd rs (Ptrofs.to_int n) k. + +(** Translation of conditional branches. *) + +Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltw r1 r2 lbl + | Cle => Pbgew r2 r1 lbl + | Cgt => Pbltw r2 r1 lbl + | Cge => Pbgew r1 r2 lbl + end. + +Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltuw r1 r2 lbl + | Cle => Pbgeuw r2 r1 lbl + | Cgt => Pbltuw r2 r1 lbl + | Cge => Pbgeuw r1 r2 lbl + end. + +Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltl r1 r2 lbl + | Cle => Pbgel r2 r1 lbl + | Cgt => Pbltl r2 r1 lbl + | Cge => Pbgel r1 r2 lbl + end. + +Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltul r1 r2 lbl + | Cle => Pbgeul r2 r1 lbl + | Cgt => Pbltul r2 r1 lbl + | Cge => Pbgeul r1 r2 lbl + end. + +Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqd rd fs1 fs2, true) + | Cne => (Pfeqd rd fs1 fs2, false) + | Clt => (Pfltd rd fs1 fs2, true) + | Cle => (Pfled rd fs1 fs2, true) + | Cgt => (Pfltd rd fs2 fs1, true) + | Cge => (Pfled rd fs2 fs1, true) + end. + +Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqs rd fs1 fs2, true) + | Cne => (Pfeqs rd fs1 fs2, false) + | Clt => (Pflts rd fs1 fs2, true) + | Cle => (Pfles rd fs1 fs2, true) + | Cgt => (Pflts rd fs2 fs1, true) + | Cge => (Pfles rd fs2 fs1, true) + end. + +Definition transl_cbranch + (cond: condition) (args: list mreg) (lbl: label) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32s c r1 r2 lbl :: k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int32u c r1 r2 lbl :: k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32s c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32u c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64s c r1 r2 lbl :: k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cbranch_int64u c r1 r2 lbl :: k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64s c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64u c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | _, _ => + Error(msg "Asmgen.transl_cond_branch") + end. + +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltw rd r1 r2 :: k + | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltw rd r2 r1 :: k + | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltuw rd r1 r2 :: k + | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltuw rd r2 r1 :: k + | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltl rd r1 r2 :: k + | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltl rd r2 r1 :: k + | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltul rd r1 r2 :: k + | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltul rd r2 r1 :: k + | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) + | Clt => sltimm32 rd r1 n k + | Cle => if Int.eq n (Int.repr Int.max_signed) + then loadimm32 rd Int.one k + else sltimm32 rd r1 (Int.add n Int.one) k + | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm32 rd r1 n k + | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) + | Clt => sltimm64 rd r1 n k + | Cle => if Int64.eq n (Int64.repr Int64.max_signed) + then loadimm32 rd Int.one k + else sltimm64 rd r1 (Int64.add n Int64.one) k + | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm64 rd r1 n k + | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) + end. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | _, _ => + Error(msg "Asmgen.transl_cond_op") + end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (res: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmv r a :: k) + | FR r, FR a => OK (Pfmv r a :: k) + | _ , _ => Error(msg "Asmgen.Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n k) + | Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfcvtdw rd X0 :: k + else Ploadfi rd f :: k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (if Float32.eq_dec f Float32.zero + then Pfcvtsw rd X0 :: k + else Ploadsi rd f :: k) + | Oaddrsymbol s ofs, nil => + do rd <- ireg_of res; + OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) + then Ploadsymbol rd s Ptrofs.zero :: addptrofs rd rd ofs k + else Ploadsymbol rd s ofs :: k) + | Oaddrstack n, nil => + do rd <- ireg_of res; + OK (addptrofs rd SP n k) + + | Ocast8signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) + | Ocast16signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) + | Oadd, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddw rd rs1 rs2 :: k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n k) + | Oneg, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psubw rd X0 rs :: 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 :: 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 :: k) + | Omulhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhw rd rs1 rs2 :: k) + | Omulhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhuw rd rs1 rs2 :: k) + | Odiv, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivw rd rs1 rs2 :: k) + | Odivu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivuw rd rs1 rs2 :: k) + | Omod, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premw rd rs1 rs2 :: k) + | Omodu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premuw rd rs1 rs2 :: k) + | Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandw rd rs1 rs2 :: k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm32 rd rs n k) + | Oor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porw rd rs1 rs2 :: k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm32 rd rs n k) + | Oxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorw rd rs1 rs2 :: k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs n k) + | Oshl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psllw rd rs1 rs2 :: k) + | Oshlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs n :: k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psraw rd rs1 rs2 :: k) + | Oshrimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psraiw rd rs n :: k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrlw rd rs1 rs2 :: k) + | Oshruimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrliw rd rs n :: k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero then Pmv rd rs :: k else + Psraiw X31 rs (Int.repr 31) :: + Psrliw X31 X31 (Int.sub Int.iwordsize n) :: + Paddw X31 rs X31 :: + Psraiw rd X31 n :: k) + + (* [Omakelong], [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pcvtl2w rd rs :: k) + | Ocast32signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + assertion (ireg_eq rd rs); + OK (Pcvtw2l rd :: k) + | Ocast32unsigned, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + assertion (ireg_eq rd rs); + OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) + | Oaddl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddl rd rs1 rs2 :: k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm64 rd rs n k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psubl rd X0 rs :: k) + | Osubl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psubl rd rs1 rs2 :: 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 :: k) + | Omullhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhl rd rs1 rs2 :: k) + | Omullhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhul rd rs1 rs2 :: k) + | Odivl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivl rd rs1 rs2 :: k) + | Odivlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivul rd rs1 rs2 :: k) + | Omodl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Preml rd rs1 rs2 :: k) + | Omodlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premul rd rs1 rs2 :: k) + | Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandl rd rs1 rs2 :: k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm64 rd rs n k) + | Oorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porl rd rs1 rs2 :: k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm64 rd rs n k) + | Oxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorl rd rs1 rs2 :: k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs n k) + | Oshll, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pslll rd rs1 rs2 :: k) + | Oshllimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psllil rd rs n :: k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psral rd rs1 rs2 :: k) + | Oshrlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrail rd rs n :: k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrll rd rs1 rs2 :: k) + | Oshrluimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrlil rd rs n :: k) + | Oshrxlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero then Pmv rd rs :: k else + Psrail X31 rs (Int.repr 63) :: + Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: + Paddl X31 rs X31 :: + Psrail rd X31 n :: k) + + | Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegd rd rs :: k) + | Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsd rd rs :: k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddd rd rs1 rs2 :: k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubd rd rs1 rs2 :: k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuld rd rs1 rs2 :: k) + | Odivf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivd rd rs1 rs2 :: k) + + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegs rd rs :: k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabss rd rs :: k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadds rd rs1 rs2 :: k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubs rd rs1 rs2 :: k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuls rd rs1 rs2 :: k) + | Odivfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivs rd rs1 rs2 :: k) + + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtsd rd rs :: k) + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtds rd rs :: k) + + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwd rd rs :: k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwud rd rs :: k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdw rd rs :: k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdwu rd rs :: k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtws rd rs :: k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwus rd rs :: k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsw rd rs :: k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtswu rd rs :: k) + + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtld rd rs :: k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlud rd rs :: k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdl rd rs :: k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdlu rd rs :: k) + | Olongofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtls rd rs :: k) + | Olonguofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlus rd rs :: k) + | Osingleoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsl rd rs :: k) + | Osingleoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtslu rd rs :: k) + + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + + | _, _ => + Error(msg "Asmgen.transl_op") + end. + +(** Accessing data in the stack frame. *) + +Definition indexed_memory_access + (mk_instr: ireg -> offset -> instruction) + (base: ireg) (ofs: ptrofs) (k: code) := + if Archi.ptr64 then + match make_immed64 (Ptrofs.to_int64 ofs) with + | Imm64_single imm => + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k + | Imm64_pair hi lo => + Pluil X31 hi :: Paddl X31 base X31 :: mk_instr X31 (Ofsimm (Ptrofs.of_int64 lo)) :: k + | Imm64_large imm => + Ploadli X31 imm :: Paddl X31 base X31 :: mk_instr X31 (Ofsimm Ptrofs.zero) :: k + end + else + match make_immed32 (Ptrofs.to_int ofs) with + | Imm32_single imm => + mk_instr base (Ofsimm (Ptrofs.of_int imm)) :: k + | Imm32_pair hi lo => + Pluiw X31 hi :: Paddw X31 base X31 :: mk_instr X31 (Ofsimm (Ptrofs.of_int lo)) :: k + end. + +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access (Pfls rd) base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access (Pfld rd) base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) + | Tany64, FR rd => OK (indexed_memory_access (Pfld_a rd) base ofs k) + | _, _ => Error (msg "Asmgen.loadind") + end. + +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access (Pfss rd) base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k) + | Tany64, FR rd => OK (indexed_memory_access (Pfsd_a rd) base ofs k) + | _, _ => Error (msg "Asmgen.storeind") + end. + +Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := + indexed_memory_access (if Archi.ptr64 then Pld dst else Plw dst) base ofs k. + +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := + indexed_memory_access (if Archi.ptr64 then Psd src else Psw src) base ofs k. + +(** Translation of memory accesses: loads, and stores. *) + +Definition transl_memory_access + (mk_instr: ireg -> offset -> instruction) + (addr: addressing) (args: list mreg) (k: code) := + match addr, args with + | Aindexed ofs, a1 :: nil => + do rs <- ireg_of a1; + OK (indexed_memory_access mk_instr rs ofs k) + | Aglobal id ofs, nil => + OK (Ploadsymbol_high X31 id ofs :: mk_instr X31 (Ofslow id ofs) :: k) + | Ainstack ofs, nil => + OK (indexed_memory_access mk_instr SP ofs k) + | _, _ => + Error(msg "Asmgen.transl_memory_access") + end. + +Definition transl_load (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: code) := + match chunk with + | Mint8signed => + do r <- ireg_of dst; + transl_memory_access (Plb r) addr args k + | Mint8unsigned => + do r <- ireg_of dst; + transl_memory_access (Plbu r) addr args k + | Mint16signed => + do r <- ireg_of dst; + transl_memory_access (Plh r) addr args k + | Mint16unsigned => + do r <- ireg_of dst; + transl_memory_access (Plhu r) addr args k + | Mint32 => + do r <- ireg_of dst; + transl_memory_access (Plw r) addr args k + | Mint64 => + do r <- ireg_of dst; + transl_memory_access (Pld r) addr args k + | Mfloat32 => + do r <- freg_of dst; + transl_memory_access (Pfls r) addr args k + | Mfloat64 => + do r <- freg_of dst; + transl_memory_access (Pfld r) addr args k + | _ => + Error (msg "Asmgen.transl_load") + end. + +Definition transl_store (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: code) := + match chunk with + | Mint8signed | Mint8unsigned => + do r <- ireg_of src; + transl_memory_access (Psb r) addr args k + | Mint16signed | Mint16unsigned => + do r <- ireg_of src; + transl_memory_access (Psh r) addr args k + | Mint32 => + do r <- ireg_of src; + transl_memory_access (Psw r) addr args k + | Mint64 => + do r <- ireg_of src; + transl_memory_access (Psd r) addr args k + | Mfloat32 => + do r <- freg_of src; + transl_memory_access (Pfss r) addr args k + | Mfloat64 => + do r <- freg_of src; + transl_memory_access (Pfsd r) addr args k + | _ => + Error (msg "Asmgen.transl_store") + end. + +(** Function epilogue *) + +Definition make_epilogue (f: Mach.function) (k: code) := + loadind_ptr SP f.(fn_retaddr_ofs) RA + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + +(** Translation of a Mach instruction. *) + +Definition transl_instr (f: Mach.function) (i: Mach.instruction) + (ep: bool) (k: code) := + match i with + | Mgetstack ofs ty dst => + loadind SP ofs ty dst k + | Msetstack src ofs ty => + storeind src SP ofs ty k + | Mgetparam ofs ty dst => + (* load via the frame pointer if it is valid *) + do c <- loadind X30 ofs ty dst k; + OK (if ep then c + else loadind_ptr SP f.(fn_link_ofs) X30 c) + | Mop op args res => + transl_op op args res k + | Mload chunk addr args dst => + transl_load chunk addr args dst k + | Mstore chunk addr args src => + transl_store chunk addr args src k + | Mcall sig (inl r) => + do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) + | Mcall sig (inr symb) => + OK (Pjal_s symb sig :: k) + | Mtailcall sig (inl r) => + do r1 <- ireg_of r; + OK (make_epilogue f (Pj_r r1 sig :: k)) + | Mtailcall sig (inr symb) => + OK (make_epilogue f (Pj_s symb sig :: k)) + | Mbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) + | Mlabel lbl => + OK (Plabel lbl :: k) + | Mgoto lbl => + OK (Pj_l lbl :: k) + | Mcond cond args lbl => + transl_cbranch cond args lbl k + | Mjumptable arg tbl => + do r <- ireg_of arg; + OK (Pbtbl r tbl :: k) + | Mreturn => + OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k)) + end. + +(** Translation of a code sequence *) + +Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := + match i with + | Msetstack src ofs ty => before + | Mgetparam ofs ty dst => negb (mreg_eq dst R30) + | Mop op args res => before && negb (mreg_eq res R30) + | _ => false + end. + +(** This is the naive definition that we no longer use because it + is not tail-recursive. It is kept as specification. *) + +Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := + match il with + | nil => OK nil + | i1 :: il' => + do k <- transl_code f il' (it1_is_parent it1p i1); + transl_instr f i1 it1p k + end. + +(** This is an equivalent definition in continuation-passing style + that runs in constant stack space. *) + +Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) + (it1p: bool) (k: code -> res code) := + match il with + | nil => k nil + | i1 :: il' => + transl_code_rec f il' (it1_is_parent it1p i1) + (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) + end. + +Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := + transl_code_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, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +Definition transl_function (f: Mach.function) := + do c <- transl_code' f f.(Mach.fn_code) true; + OK (mkfunction f.(Mach.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: + storeind_ptr RA SP f.(fn_retaddr_ofs) c)). + +Definition transf_function (f: Mach.function) : res Asm.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Mach.program) : res Asm.program := + transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v new file mode 100644 index 00000000..cc45a8de --- /dev/null +++ b/mppa_k1c/Asmgenproof.v @@ -0,0 +1,1028 @@ +(* *********************************************************************) +(* *) +(* 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 Mach Conventions Asm. +Require Import Asmgen Asmgenproof0 Asmgenproof1. + +Definition match_prog (p: Mach.program) (tp: Asm.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +(** * Properties of control flow *) + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + omega. +Qed. + +Lemma exec_straight_exec: + forall fb f c ep tf tc c' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + exec_straight tge tf tc rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inv H. + eapply exec_straight_steps_1; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c ep tf tc c' ep' tc' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + transl_code f c' ep' = OK tc' -> + exec_straight tge tf tc rs m tc' rs' m' -> + transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. +Proof. + intros. inv H. + exploit exec_straight_steps_2; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Remark loadimm32_label: + forall r n k, tail_nolabel k (loadimm32 r n k). +Proof. + intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. + unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. +Qed. +Hint Resolve loadimm32_label: labels. + +Remark opimm32_label: + forall op opimm r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm32 op opimm r1 r2 n k). +Proof. + intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. + unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. +Qed. +Hint Resolve opimm32_label: labels. + +Remark loadimm64_label: + forall r n k, tail_nolabel k (loadimm64 r n k). +Proof. + intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. + unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. +Qed. +Hint Resolve loadimm64_label: labels. + +Remark opimm64_label: + forall op opimm r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm64 op opimm r1 r2 n k). +Proof. + intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. + unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. +Qed. +Hint Resolve opimm64_label: labels. + +Remark addptrofs_label: + forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). +Proof. + unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. + destruct Archi.ptr64. apply opimm64_label; TailNoLabel. apply opimm32_label; TailNoLabel. +Qed. +Hint Resolve addptrofs_label: labels. + +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cbranch_label: + forall cond args lbl k c, + transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +Qed. + +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* apply opimm32_label; intros; exact I. +* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +- unfold transl_condimm_int32u. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). + apply opimm32_label; intros; exact I. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* apply opimm64_label; intros; exact I. +* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +- unfold transl_condimm_int64u. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). + apply opimm64_label; intros; exact I. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +Qed. + +Remark transl_op_label: + forall op args r k c, + transl_op op args r k = OK c -> tail_nolabel k c. +Proof. +Opaque Int.eq. + unfold transl_op; intros; destruct op; TailNoLabel. +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. ++ TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- eapply transl_cond_op_label; eauto. +Qed. + +Remark indexed_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) base ofs k, + (forall r o, nolabel (mk_instr r o)) -> + tail_nolabel k (indexed_memory_access mk_instr base ofs k). +Proof. + unfold indexed_memory_access; intros. + destruct Archi.ptr64. + destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. + destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. +Qed. + +Remark loadind_label: + forall base ofs ty dst k c, + loadind base ofs ty dst k = OK c -> tail_nolabel k c. +Proof. + unfold loadind; intros. + destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark storeind_label: + forall src base ofs ty k c, + storeind src base ofs ty k = OK c -> tail_nolabel k c. +Proof. + unfold storeind; intros. + destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark loadind_ptr_label: + forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark storeind_ptr_label: + forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark transl_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) addr args k c, + (forall r o, nolabel (mk_instr r o)) -> + transl_memory_access mk_instr addr args k = OK c -> + tail_nolabel k c. +Proof. + unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. +Qed. + +Remark make_epilogue_label: + forall f k, tail_nolabel k (make_epilogue f k). +Proof. + unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. +Qed. + +Lemma transl_instr_label: + forall f i ep k c, + transl_instr f i ep k = OK c -> + match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. +Proof. + unfold transl_instr; intros; destruct i; TailNoLabel. +- eapply loadind_label; eauto. +- eapply storeind_label; eauto. +- destruct ep. eapply loadind_label; eauto. + eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. +- eapply transl_op_label; eauto. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct s0; monadInv H; TailNoLabel. +- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). +- eapply transl_cbranch_label; eauto. +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +Qed. + +Lemma transl_instr_label': + forall lbl f i ep k c, + transl_instr f i ep k = OK c -> + find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply B). + intros. subst c. simpl. auto. +Qed. + +Lemma transl_code_label: + forall lbl f c ep tc, + transl_code f c ep = OK tc -> + match Mach.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). + generalize (Mach.is_label_correct lbl a). + destruct (Mach.is_label lbl a); intros. + subst a. simpl in EQ. exists x; auto. + eapply IHc; eauto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match Mach.find_label lbl f.(Mach.fn_code) with + | None => find_label lbl tf.(fn_code) = None + | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. + simpl. destruct (storeind_ptr_label X1 X2 (fn_retaddr_ofs f) x) as [A B]; rewrite B. + eapply transl_code_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 -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros [tc [A B]]. + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmgenproof0.return_address_exists; eauto. +- intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. + rewrite transl_code'_transl_code in EQ0. + exists x; exists true; split; auto. unfold fn_code. + constructor. apply (storeind_ptr_label X1 X2 (fn_retaddr_ofs f0) x). +- 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. +*) + +Inductive match_states: Mach.state -> Asm.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#X30 = parent_sp s), + match_states (Mach.State s fb sp c ms m) + (Asm.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Mach.Callstate s fb ms m) + (Asm.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Mach.Returnstate s ms m) + (Asm.State rs m'). + +Lemma exec_straight_steps: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists rs2, + exec_straight tge tf c rs1 m1' k rs2 m2' + /\ agree ms2 sp rs2 + /\ (it1_is_parent ep i = true -> rs2#X30 = parent_sp s)) -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c ms2 m2) st'. +Proof. + intros. inversion H2. subst. monadInv H7. + exploit H3; eauto. intros [rs2 [A [B C]]]. + exists (State rs2 m2'); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. + +Lemma exec_straight_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +Lemma exec_straight_opt_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + inv A. +- exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +- exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the 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. *) + +Definition measure (s: Mach.state) : nat := + match s with + | Mach.State _ _ _ _ _ _ => 0%nat + | Mach.Callstate _ _ _ _ => 0%nat + | Mach.Returnstate _ _ _ => 1%nat + end. + +Remark preg_of_not_X30: forall r, negb (mreg_eq r R30) = true -> IR X30 <> preg_of r. +Proof. + intros. change (IR X30) with (preg_of R30). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) + +Theorem step_simulation: + forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + +- (* Mlabel *) + left; eapply exec_straight_steps; eauto; intros. + monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. apply agree_nextinstr; auto. simpl; congruence. + +- (* Mgetstack *) + unfold load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto with asmgen. congruence. + simpl; congruence. + +- (* Msetstack *) + unfold store_stack in H. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + left; eapply exec_straight_steps; eauto. + rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. + exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exists rs'; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. + +- (* Mgetparam *) + assert (f0 = f) by congruence; subst f0. + unfold load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. +Opaque loadind. + left; eapply exec_straight_steps; eauto; intros. monadInv TR. + destruct ep. +(* X30 contains parent *) + exploit loadind_correct. eexact EQ. + instantiate (2 := rs0). rewrite DXP; eauto. congruence. + intros [rs1 [P [Q R]]]. + exists rs1; split. eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_X30; auto. +(* GPR11 does not contain parent *) + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. congruence. intros [rs1 [P [Q R]]]. + exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. + intros [rs2 [S [T U]]]. + exists rs2; split. eapply exec_straight_trans; eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs1#X30 <- (rs2#X30)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' X30). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_X30; auto. + +- (* Mop *) + assert (eval_operation tge sp op (map rs args) m = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. split. auto. + apply agree_set_undef_mreg with rs0; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_X30; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + +- (* Mload *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. + split. eapply agree_set_undef_mreg; eauto. congruence. + intros; auto with asmgen. + simpl; congruence. + +- (* Mstore *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + left; eapply exec_straight_steps; eauto. + intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + exists rs2; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; congruence. + +- (* Mcall *) + assert (f0 = f) by congruence. subst f0. + inv AT. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct ros as [rf|fid]; simpl in H; monadInv H5. ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. ++ (* Direct call *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + +- (* Mtailcall *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. + destruct ros as [rf|fid]; simpl in H; monadInv H7. ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. ++ (* Direct call *) + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. + +- (* Mbuiltin *) + inv AT. monadInv H4. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + left. econstructor; split. apply plus_one. + eapply exec_step_builtin. eauto. eauto. + eapply find_instr_tail; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H1. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. + congruence. + +- (* Mgoto *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H4. + exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. + left; exists (State rs' m'); split. + apply plus_one. econstructor; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + econstructor; eauto. + eapply agree_exten; eauto with asmgen. + congruence. + +- (* Mcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_opt_steps_goto; eauto. + intros. simpl in TR. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exists jmp; exists k; exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + exact B. + +- (* Mcond false *) + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). + exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + simpl. congruence. + +- (* Mjumptable *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H6. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H5); intro NOOV. + exploit find_label_goto_label. eauto. eauto. + instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). + Simpl. eauto. + eauto. + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H. intros LD; inv LD. + left; econstructor; split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail; eauto. + simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. + econstructor; eauto. + eapply agree_undef_regs; eauto. + simpl. intros. rewrite C; auto with asmgen. Simpl. + congruence. + +- (* Mreturn *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. simpl in H6; monadInv H6. + assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + +- (* internal function *) + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. + unfold store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) :: + storeind_ptr RA SP (fn_retaddr_ofs f) x0) in *. + set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. + set (rs2 := nextinstr (rs0#X30 <- (parent_sp s) #SP <- sp #X31 <- Vundef)). + exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) RA x0 rs2 m2'). + rewrite chunk_of_Tptr in P. change (rs2 X1) with (rs0 X1). rewrite ATLR. + change (rs2 X2) with sp. eexact P. + congruence. congruence. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: + exec_straight tge tf + tf.(fn_code) rs0 m' + x0 rs3 m3'). + { change (fn_code tf) with tfbody; unfold tfbody. + apply exec_straight_step with rs2 m2'. + unfold exec_instr. rewrite C. fold sp. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. + reflexivity. + eexact U. } + exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3 m3'); split. + eapply exec_straight_steps_1; eauto. omega. constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextinstr. 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. rewrite V by auto with asmgen. reflexivity. + +- (* external function *) + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. apply agree_set_pair; auto. + +- (* return *) + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, Mach.initial_state prog st1 -> + exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R10 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v new file mode 100644 index 00000000..7f070c12 --- /dev/null +++ b/mppa_k1c/Asmgenproof1.v @@ -0,0 +1,1411 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Errors Maps. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Mach Conventions. +Require Import Asm Asmgen Asmgenproof0. + +(** Decomposition of integer constants. *) + +Lemma make_immed32_sound: + forall n, + match make_immed32 n with + | Imm32_single imm => n = imm + | Imm32_pair hi lo => n = Int.add (Int.shl hi (Int.repr 12)) lo + end. +Proof. + intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). + predSpec Int.eq Int.eq_spec n lo. +- auto. +- set (m := Int.sub n lo). + assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). + assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). + { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + auto using Int.eqmod_sub, Int.eqmod_refl. } + assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). + { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. + apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists (two_p (32-12)); auto. } + assert (D: Int.modu m (Int.repr 4096) = Int.zero). + { apply Int.eqmod_mod_eq in C. unfold Int.modu. + change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. + reflexivity. + apply two_p_gt_ZERO; omega. } + rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. + rewrite Int.shl_mul_two_p. + change (two_p (Int.unsigned (Int.repr 12))) with 4096. + replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. + unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). + rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. + rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). + rewrite D. apply Int.add_zero. +Qed. + +Lemma make_immed64_sound: + forall n, + match make_immed64 n with + | Imm64_single imm => n = imm + | Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo + | Imm64_large imm => n = imm + end. +Proof. + intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). + predSpec Int64.eq Int64.eq_spec n lo. +- auto. +- set (m := Int64.sub n lo). + set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). + predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). + auto. + auto. +Qed. + +(** Properties of registers *) + +Lemma ireg_of_not_X31: + forall m r, ireg_of m = OK r -> IR r <> IR X31. +Proof. + intros. erewrite <- ireg_of_eq; eauto with asmgen. +Qed. + +Lemma ireg_of_not_X31': + forall m r, ireg_of m = OK r -> r <> X31. +Proof. + intros. apply ireg_of_not_X31 in H. congruence. +Qed. + +Hint Resolve ireg_of_not_X31 ireg_of_not_X31': asmgen. + +(** Useful simplification tactic *) + +Ltac Simplif := + ((rewrite nextinstr_inv by eauto with asmgen) + || (rewrite nextinstr_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextinstr_pc) + || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(** * Correctness of RISC-V constructor functions *) + +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', + exec_straight ge fn (loadimm32 rd n k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int.add_zero_l; Simpl. + intros; Simpl. +- rewrite E. apply load_hilo32_correct. +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 <> X31 -> + 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 <> X31 -> 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 X31 hi lo (op rd r1 X31 :: 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 loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int64.add_zero_l; Simpl. + intros; Simpl. +- exploit load_hilo64_correct; eauto. intros (rs' & A & B & C). + rewrite E. exists rs'; eauto. +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + +Lemma opimm64_correct: + forall (op: ireg -> ireg0 -> ireg0 -> instruction) + (opi: ireg -> ireg0 -> int64 -> 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 (Vlong n)))) m) -> + forall rd r1 n k rs, + r1 <> X31 -> + exists rs', + exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs##r1 (Vlong n) + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm64. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +- destruct (load_hilo64_correct X31 hi lo (op rd r1 X31 :: 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 *) + +Lemma addptrofs_correct: + forall rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + unfold addptrofs; intros. + destruct (Ptrofs.eq_dec n Ptrofs.zero). +- subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. + intros; Simpl. +- destruct Archi.ptr64 eqn:SF. ++ unfold addimm64. + exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. simpl. destruct (rs r1); simpl; auto. rewrite SF. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. ++ unfold addimm32. + exploit (opimm32_correct Paddw Paddiw Val.add); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. simpl. destruct (rs r1); simpl; auto. rewrite SF. + rewrite Ptrofs.of_int_to_int by auto. auto. +Qed. + +Lemma addptrofs_correct_2: + forall rd r1 n k (rs: regset) m b ofs, + r1 <> X31 -> rs#r1 = Vptr b ofs -> + 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 <> X31 -> 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 *) + +Lemma transl_cbranch_int32s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int32u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cbranch_int64s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int64u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cond_float_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_float cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- rewrite Val.negate_cmpf_eq. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_single_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_single cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. +Qed. + +Remark branch_on_X31: + forall normal lbl (rs: regset) m b, + rs#X31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 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 + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge fn c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma transl_cbranch_correct_1: + forall cond args lbl k c m ms b sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some b -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TRANSL EVAL AG MEXT. + set (vl' := map rs (map preg_of args)). + assert (EVAL': eval_condition cond vl' m' = Some b). + { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } + clear EVAL MEXT AG. + destruct cond; simpl in TRANSL; ArgsInv. +- exists rs, (transl_cbranch_int32s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. +- exists rs, (transl_cbranch_int32u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- exists rs, (transl_cbranch_int64s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. +- exists rs, (transl_cbranch_int64u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +Qed. + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some true -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. + +Lemma transl_cbranch_correct_false: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some false -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', + exec_straight ge fn c rs m' k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. exploit transl_cbranch_correct_1; eauto. simpl. + intros (rs' & insn & A & B & C). + exists (nextinstr rs'). + split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. + intros; Simpl. +Qed. + +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. + simpl. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. + simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. + simpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. + simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32s. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int.lt. rewrite zlt_false. auto. + change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. + generalize (Int.signed_range i); omega. +* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. + unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). + destruct (zlt (Int.signed n) (Int.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int.add_signed. symmetry; apply Int.signed_repr. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32u. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64s. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int64.lt. rewrite zlt_false. auto. + change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. + generalize (Int64.signed_range i); omega. +* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. + unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). + destruct (zlt (Int64.signed n) (Int64.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64u. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; auto. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* 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. +Qed. + +(** 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. + +(* Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto | reflexivity] + | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } +Opaque Int.eq. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* move *) + destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* intconst *) + exploit loadimm32_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* longconst *) + exploit loadimm64_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* floatconst *) + destruct (Float.eq_dec n Float.zero). ++ subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. +- (* singleconst *) + destruct (Float32.eq_dec n Float32.zero). ++ subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. +- (* addrsymbol *) + destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. ++ TranslOpSimpl. +- (* stackoffset *) + exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* cast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* cast16signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* addimm *) + exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* andimm *) + exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* orimm *) + exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* xorimm *) + exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* shrximm *) + clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. +- (* longofintu *) + econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. + split; intros; Simpl. destruct (rs x0); auto. simpl. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. + rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. +- (* addlimm *) + exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* andimm *) + exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* orimm *) + exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* xorimm *) + exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* shrxlimm *) + clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. +- (* cond *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. +Qed. + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: + forall mk_instr base ofs k rs m, + base <> X31 -> + exists base' ofs' rs', + exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m + (mk_instr base' ofs' :: k) rs' m + /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + unfold indexed_memory_access; intros. + destruct Archi.ptr64 eqn:SF. +- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. + destruct (make_immed64 (Ptrofs.to_int64 ofs)). ++ 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. +- 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 -> instruction) rd m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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 -> + base <> X31 -> rd <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, r <> PC -> r <> X31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_load. rewrite B, LOAD. eauto. Simpl. + split; intros; Simpl. +Qed. + +Lemma indexed_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) r1 m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + forall (base: ireg) ofs k (rs: regset) m', + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> + base <> X31 -> r1 <> X31 -> r1 <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. + intros; Simpl. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + base <> X31 -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR LOAD NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). + { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_load_access_correct; eauto with asmgen. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + base <> X31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR STORE NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. +Qed. + +Lemma loadind_ptr_correct: + forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> + base <> X31 -> + exists rs', + exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> X31 -> r <> dst -> rs'#r = rs#r. +Proof. + intros. eapply indexed_load_access_correct; eauto with asmgen. + intros. unfold Mptr. destruct Archi.ptr64; auto. +Qed. + +Lemma storeind_ptr_correct: + forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', + Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + base <> X31 -> src <> X31 -> + exists rs', + exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. + intros. unfold Mptr. destruct Archi.ptr64; auto. +Qed. + +Lemma transl_memory_access_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ofs rs', + exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m + /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access in TR; destruct addr; ArgsInv. +- (* indexed *) + inv EV. apply indexed_memory_access_correct; eauto with asmgen. +- (* global *) + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. + constructor. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. unfold eval_offset. apply low_high_half. +- (* stack *) + inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. +Qed. + +Lemma transl_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c rd (rs: regset) m v v', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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' -> + rd <> PC -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> X31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros INSTR TR EV LOAD NOTPC. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> + r1 <> PC -> r1 <> X31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOTPC NOT31. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. + intros; Simpl. +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 -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV LOAD. + assert (A: exists mk_instr, + transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). + { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } + destruct A as (mk_instr & B & C). + eapply transl_load_access_correct; eauto with asmgen. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m a m', + transl_store chunk addr args src k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR EV STORE. + assert (A: exists mk_instr chunk', + transl_memory_access mk_instr addr args k = OK c + /\ (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). + { unfold transl_store in TR; destruct chunk; ArgsInv; + (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). + destruct a; auto. apply Mem.store_signed_unsigned_8. + destruct a; auto. apply Mem.store_signed_unsigned_16. + } + destruct A as (mk_instr & chunk' & B & C & D). + rewrite D in STORE; clear D. + eapply transl_store_access_correct; eauto with asmgen. +Qed. + +(** Function epilogues *) + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> X31 -> rs'#r = rs#r). +Proof. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) RA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). + rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. congruence. + intros (rs1 & A1 & B1 & C1). + econstructor; econstructor; split. + eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. + rewrite (C1 X2) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. + rewrite FREE'. eauto. auto. + split. apply agree_nextinstr. apply agree_set_other; auto with asmgen. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; apply C1; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. + split. Simpl. + intros. Simpl. +Qed. + +End CONSTRUCTORS. + + + diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml new file mode 100644 index 00000000..0c981d11 --- /dev/null +++ b/mppa_k1c/CBuiltins.ml @@ -0,0 +1,61 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Processor-dependent builtin C functions *) + +open C + +let builtins = { + Builtins.typedefs = [ + "__builtin_va_list", TPtr(TVoid [], []) + ]; + Builtins.functions = [ + (* Synchronization *) + "__builtin_fence", + (TVoid [], [], false); + (* Integer arithmetic *) + "__builtin_bswap64", + (TInt(IULongLong, []), [TInt(IULongLong, [])], false); + (* Float arithmetic *) + "__builtin_fmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fnmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fnmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], + false); + "__builtin_fmax", + (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmin", + (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + ] +} + +let va_list_type = TPtr(TVoid [], []) (* to check! *) +let size_va_list = if Archi.ptr64 then 8 else 4 +let va_list_scalar = true + +(* Expand memory references inside extended asm statements. Used in C2C. *) + +let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/mppa_k1c/CombineOp.v b/mppa_k1c/CombineOp.v new file mode 100644 index 00000000..6236f38f --- /dev/null +++ b/mppa_k1c/CombineOp.v @@ -0,0 +1,138 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Op. +Require Import CSEdomain. + +Section COMBINE. + +Variable get: valnum -> option rhs. + +Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) := + match cond, args with + | Ccompimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | Ccompuimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompuimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | _, _ => None + end. + +Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := + match addr, args with + | Aindexed n, x::nil => + match get x with + | Some(Op (Oaddimm m) ys) => + if Archi.ptr64 then None else Some(Aindexed (Ptrofs.add (Ptrofs.of_int m) n), ys) + | Some(Op (Oaddlimm m) ys) => + if Archi.ptr64 then Some(Aindexed (Ptrofs.add (Ptrofs.of_int64 m) n), ys) else None + | _ => None + end + | _, _ => None + end. + +Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) := + match op, args with + | Oaddimm n, x :: nil => + match get x with + | Some(Op (Oaddimm m) ys) => Some(Oaddimm (Int.add m n), ys) + | _ => None + end + | Oandimm n, x :: nil => + match get x with + | Some(Op (Oandimm m) ys) => + Some(let p := Int.and m n in + if Int.eq p m then (Omove, x :: nil) else (Oandimm p, ys)) + | _ => None + end + | Oorimm n, x :: nil => + match get x with + | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys) + | _ => None + end + | Oxorimm n, x :: nil => + match get x with + | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys) + | _ => None + end + | Oaddlimm n, x :: nil => + match get x with + | Some(Op (Oaddlimm m) ys) => Some(Oaddlimm (Int64.add m n), ys) + | _ => None + end + | Oandlimm n, x :: nil => + match get x with + | Some(Op (Oandlimm m) ys) => + Some(let p := Int64.and m n in + if Int64.eq p m then (Omove, x :: nil) else (Oandlimm p, ys)) + | _ => None + end + | Oorlimm n, x :: nil => + match get x with + | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys) + | _ => None + end + | Oxorlimm n, x :: nil => + match get x with + | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys) + | _ => None + end + | Ocmp cond, _ => + match combine_cond cond args with + | Some(cond', args') => Some(Ocmp cond', args') + | None => None + end + | _, _ => None + end. + +End COMBINE. diff --git a/mppa_k1c/CombineOpproof.v b/mppa_k1c/CombineOpproof.v new file mode 100644 index 00000000..a24de1e5 --- /dev/null +++ b/mppa_k1c/CombineOpproof.v @@ -0,0 +1,173 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import FunInd. +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import CSEdomain. +Require Import CombineOp. + +Section COMBINE. + +Variable ge: genv. +Variable sp: val. +Variable m: mem. +Variable get: valnum -> option rhs. +Variable valu: valnum -> val. +Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v). + +Lemma get_op_sound: + forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v). +Proof. + intros. exploit get_sound; eauto. intros REV; inv REV; auto. +Qed. + +Ltac UseGetSound := + match goal with + | [ H: get _ = Some _ |- _ ] => + let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv) + end. + +Lemma combine_compimm_ne_0_sound: + forall x cond args, + combine_compimm_ne_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_0_sound: + forall x cond args, + combine_compimm_eq_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_1_sound: + forall x cond args, + combine_compimm_eq_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_ne_1_sound: + forall x cond args, + combine_compimm_ne_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Theorem combine_cond_sound: + forall cond args cond' args', + combine_cond get cond args = Some(cond', args') -> + eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* compimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. + (* compuimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compuimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compuimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compuimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. +Qed. + +Theorem combine_addr_sound: + forall addr args addr' args', + combine_addr get addr args = Some(addr', args') -> + eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). +Proof. + intros. functional inversion H; subst. +- (* indexed - addimm *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +- (* indexed - addimml *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +Qed. + +Theorem combine_op_sound: + forall op args op' args', + combine_op get op args = Some(op', args') -> + eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* addimm - addimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.add_assoc. auto. + (* andimm - andimm *) + - UseGetSound; simpl. + generalize (Int.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.and_assoc. auto. + (* orimm - orimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto. + (* xorimm - xorimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. + (* addlimm - addlimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.addl_assoc. auto. + (* andlimm - andlimm *) + - UseGetSound; simpl. + generalize (Int64.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.andl_assoc. auto. + (* orlimm - orlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. + (* xorlimm - xorlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. + (* cmp *) + - simpl. decEq; decEq. eapply combine_cond_sound; eauto. +Qed. + +End COMBINE. diff --git a/mppa_k1c/ConstpropOp.v b/mppa_k1c/ConstpropOp.v new file mode 100644 index 00000000..e7391ab5 --- /dev/null +++ b/mppa_k1c/ConstpropOp.v @@ -0,0 +1,613 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Archi. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +(** Original definition: +<< +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. +>> +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list aval), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case5: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case6: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_case7: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case8: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list aval), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list aval) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case5 c r1 r2 n1 v2 + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case6 c r1 r2 v1 n2 + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case7 c r1 r2 n1 v2 + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case8 c r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl + end. + +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list aval) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_case5 c r1 r2 n1 v2 => (* Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case6 c r1 r2 v1 n2 => (* Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccomplimm c n2, r1 :: nil) + | cond_strength_reduction_case7 c r1 r2 n1 v2 => (* Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case8 c r1 r2 v1 n2 => (* Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccompluimm c n2, r1 :: nil) + | cond_strength_reduction_default cond args vl => + (cond, args) + end. + + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +(** Original definition: +<< +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. +>> +*) + +Inductive make_cmp_cases: forall (c: condition) (args: list reg) (vl: list aval), Type := + | make_cmp_case1: forall n r1 v1, make_cmp_cases (Ccompimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case2: forall n r1 v1, make_cmp_cases (Ccompimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_case3: forall n r1 v1, make_cmp_cases (Ccompuimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case4: forall n r1 v1, make_cmp_cases (Ccompuimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_default: forall (c: condition) (args: list reg) (vl: list aval), make_cmp_cases c args vl. + +Definition make_cmp_match (c: condition) (args: list reg) (vl: list aval) := + match c as zz1, args as zz2, vl as zz3 return make_cmp_cases zz1 zz2 zz3 with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case1 n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case2 n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case3 n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case4 n r1 v1 + | c, args, vl => make_cmp_default c args vl + end. + +Definition make_cmp (c: condition) (args: list reg) (vl: list aval) := + match make_cmp_match c args vl with + | make_cmp_case1 n r1 v1 => (* Ccompimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case2 n r1 v1 => (* Ccompimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_case3 n r1 v1 => (* Ccompuimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case4 n r1 v1 => (* Ccompuimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_default c args vl => + make_cmp_base c args vl + end. + + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshlimm l, r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Definition make_divimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oaddlimm n, r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r1 r2: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r1 :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r1 :: nil) + | None => (Omull, r1 :: r2 :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). + +(** Original definition: +<< +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. +>> +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list aval), Type := + | op_strength_reduction_case1: forall r1 v1, op_strength_reduction_cases (Ocast8signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case2: forall r1 v1, op_strength_reduction_cases (Ocast16signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case3: forall r1 r2 n1 v2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case4: forall r1 r2 v1 n2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case12: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case13: forall n r1 v1, op_strength_reduction_cases (Oandimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case14: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case15: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case16: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case17: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case18: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case20: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case21: forall r1 r2 n1 v2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case22: forall r1 r2 v1 n2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case23: forall r1 r2 v1 n2, op_strength_reduction_cases (Osubl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case24: forall r1 r2 n1 v2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case26: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case27: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case28: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case29: forall r1 r2 n1 v2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case30: forall r1 r2 v1 n2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case31: forall n r1 v1, op_strength_reduction_cases (Oandlimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case32: forall r1 r2 n1 v2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case33: forall r1 r2 v1 n2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case34: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case35: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case36: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshll) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case37: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case38: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrlu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case39: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_case40: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (v1 :: F n2 :: nil) + | op_strength_reduction_case41: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (F n1 :: v2 :: nil) + | op_strength_reduction_case42: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (v1 :: FS n2 :: nil) + | op_strength_reduction_case43: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (FS n1 :: v2 :: nil) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list aval), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list aval) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Ocast8signed, r1 :: nil, v1 :: nil => op_strength_reduction_case1 r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => op_strength_reduction_case2 r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case3 r1 r2 n1 v2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case4 r1 r2 v1 n2 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case6 r1 r2 n1 v2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case11 r1 r2 n1 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case12 r1 r2 v1 n2 + | Oandimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case13 n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case14 r1 r2 n1 v2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case15 r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case16 r1 r2 n1 v2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case18 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 r1 r2 v1 n2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case21 r1 r2 n1 v2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case22 r1 r2 v1 n2 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case23 r1 r2 v1 n2 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case24 r1 r2 n1 v2 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case26 r1 r2 v1 n2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case27 r1 r2 v1 n2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case28 r1 r2 v1 n2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case29 r1 r2 n1 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case30 r1 r2 v1 n2 + | Oandlimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case31 n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case32 r1 r2 n1 v2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case33 r1 r2 v1 n2 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case34 r1 r2 n1 v2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case35 r1 r2 v1 n2 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case36 r1 r2 v1 n2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case37 r1 r2 v1 n2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case38 r1 r2 v1 n2 + | Ocmp c, args, vl => op_strength_reduction_case39 c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => op_strength_reduction_case40 r1 r2 v1 n2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => op_strength_reduction_case41 r1 r2 n1 v2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => op_strength_reduction_case42 r1 r2 v1 n2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => op_strength_reduction_case43 r1 r2 n1 v2 + | op, args, vl => op_strength_reduction_default op args vl + end. + +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list aval) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 v1 => (* Ocast8signed, r1 :: nil, v1 :: nil *) + make_cast8signed r1 v1 + | op_strength_reduction_case2 r1 v1 => (* Ocast16signed, r1 :: nil, v1 :: nil *) + make_cast16signed r1 v1 + | op_strength_reduction_case3 r1 r2 n1 v2 => (* Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_addimm n1 r2 + | op_strength_reduction_case4 r1 r2 v1 n2 => (* Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm n2 r1 + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case6 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_mulimm n1 r2 r1 + | op_strength_reduction_case7 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 r2 + | op_strength_reduction_case8 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_moduimm n2 r1 r2 + | op_strength_reduction_case11 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_andimm n1 r2 v2 + | op_strength_reduction_case12 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 v1 + | op_strength_reduction_case13 n r1 v1 => (* Oandimm n, r1 :: nil, v1 :: nil *) + make_andimm n r1 v1 + | op_strength_reduction_case14 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_orimm n1 r2 + | op_strength_reduction_case15 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case16 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_xorimm n1 r2 + | op_strength_reduction_case17 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case18 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 r2 + | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 r2 + | op_strength_reduction_case20 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 r2 + | op_strength_reduction_case21 r1 r2 n1 v2 => (* Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_addlimm n1 r2 + | op_strength_reduction_case22 r1 r2 v1 n2 => (* Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_addlimm n2 r1 + | op_strength_reduction_case23 r1 r2 v1 n2 => (* Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_addlimm (Int64.neg n2) r1 + | op_strength_reduction_case24 r1 r2 n1 v2 => (* Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_mullimm n1 r2 r1 + | op_strength_reduction_case25 r1 r2 v1 n2 => (* Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_mullimm n2 r1 r2 + | op_strength_reduction_case26 r1 r2 v1 n2 => (* Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divlimm n2 r1 r2 + | op_strength_reduction_case27 r1 r2 v1 n2 => (* Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divluimm n2 r1 r2 + | op_strength_reduction_case28 r1 r2 v1 n2 => (* Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_modluimm n2 r1 r2 + | op_strength_reduction_case29 r1 r2 n1 v2 => (* Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_andlimm n1 r2 v2 + | op_strength_reduction_case30 r1 r2 v1 n2 => (* Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_andlimm n2 r1 v1 + | op_strength_reduction_case31 n r1 v1 => (* Oandlimm n, r1 :: nil, v1 :: nil *) + make_andlimm n r1 v1 + | op_strength_reduction_case32 r1 r2 n1 v2 => (* Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_orlimm n1 r2 + | op_strength_reduction_case33 r1 r2 v1 n2 => (* Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_orlimm n2 r1 + | op_strength_reduction_case34 r1 r2 n1 v2 => (* Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_xorlimm n1 r2 + | op_strength_reduction_case35 r1 r2 v1 n2 => (* Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_xorlimm n2 r1 + | op_strength_reduction_case36 r1 r2 v1 n2 => (* Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shllimm n2 r1 r2 + | op_strength_reduction_case37 r1 r2 v1 n2 => (* Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrlimm n2 r1 r2 + | op_strength_reduction_case38 r1 r2 v1 n2 => (* Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrluimm n2 r1 r2 + | op_strength_reduction_case39 c args vl => (* Ocmp c, args, vl *) + make_cmp c args vl + | op_strength_reduction_case40 r1 r2 v1 n2 => (* Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil *) + make_mulfimm n2 r1 r1 r2 + | op_strength_reduction_case41 r1 r2 n1 v2 => (* Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil *) + make_mulfimm n1 r2 r1 r2 + | op_strength_reduction_case42 r1 r2 v1 n2 => (* Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil *) + make_mulfsimm n2 r1 r1 r2 + | op_strength_reduction_case43 r1 r2 n1 v2 => (* Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil *) + make_mulfsimm n1 r2 r1 r2 + | op_strength_reduction_default op args vl => + (op, args) + end. + + +(** Original definition: +<< +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 Archi.pic_code tt + then (addr, args) + else (Aglobal symb (Ptrofs.add n1 n), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 n), nil) + | _, _, _ => + (addr, args) + end. +>> +*) + +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_case1: forall n r1 symb n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Gl symb n1) :: nil) + | addr_strength_reduction_case2: forall n r1 n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Stk n1) :: nil) + | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_cases addr args vl. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => addr_strength_reduction_case1 n r1 symb n1 + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => addr_strength_reduction_case2 n r1 n1 + | addr, args, vl => addr_strength_reduction_default addr args vl + end. + +Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := + match addr_strength_reduction_match addr args vl with + | addr_strength_reduction_case1 n r1 symb n1 => (* Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil *) + if Archi.pic_code tt then (addr, args) else (Aglobal symb (Ptrofs.add n1 n), nil) + | addr_strength_reduction_case2 n r1 n1 => (* Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil *) + (Ainstack (Ptrofs.add n1 n), nil) + | addr_strength_reduction_default addr args vl => + (addr, args) + end. + + diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp new file mode 100644 index 00000000..aab2424d --- /dev/null +++ b/mppa_k1c/ConstpropOp.vp @@ -0,0 +1,309 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Archi. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshlimm l, r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Definition make_divimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oaddlimm n, r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r1 r2: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r1 :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r1 :: nil) + | None => (Omull, r1 :: r2 :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. + +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 Archi.pic_code tt + then (addr, args) + else (Aglobal symb (Ptrofs.add n1 n), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 n), nil) + | _, _, _ => + (addr, args) + end. + diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v new file mode 100644 index 00000000..765aa035 --- /dev/null +++ b/mppa_k1c/ConstpropOpproof.v @@ -0,0 +1,745 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for operator strength reduction. *) + +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. +Require Import ConstpropOp. + +Section STRENGTH_REDUCTION. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. +Variable ae: AE.t. +Variable e: regset. +Variable m: mem. +Hypothesis MATCH: ematch bc e ae. + +Lemma match_G: + forall r id ofs, + AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). +Proof. + intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Lemma match_S: + forall r ofs, + AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). +Proof. + intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = AE.get ?r ae |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. + +Ltac SimplVM := + match goal with + | [ H: vmatch _ ?v (I ?n) |- _ ] => + let E := fresh in + assert (E: v = Vint n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (L ?n) |- _ ] => + let E := fresh in + assert (E: v = Vlong n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (F ?n) |- _ ] => + let E := fresh in + assert (E: v = Vfloat n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (FS ?n) |- _ ] => + let E := fresh in + assert (E: v = Vsingle n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); + clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); + clear H; SimplVM + | _ => idtac + end. + +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* long *) + destruct ptr64; inv H2. exists (Vlong n); auto. +- (* float *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + inv H2. exists (Genv.symbol_address ge id ofs); auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args vl, + vl = map (fun r => AE.get r ae) args -> + let (cond', args') := cond_strength_reduction cond args vl in + eval_condition cond' e##args' m = eval_condition cond e##args m. +Proof. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. +- apply Val.swap_cmp_bool. +- auto. +- apply Val.swap_cmpu_bool. +- auto. +- apply Val.swap_cmpl_bool. +- auto. +- apply Val.swap_cmplu_bool. +- auto. +- auto. +Qed. + +Lemma make_cmp_base_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp_base c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros. unfold make_cmp_base. + generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. + econstructor; split. simpl; eauto. rewrite EQ. auto. +Qed. + +Lemma make_cmp_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros c args vl. + assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> + e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). + { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } + unfold make_cmp. case (make_cmp_match c args vl); intros. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- apply make_cmp_base_correct; auto. +Qed. + +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. + destruct Archi.ptr64; auto. + exists (Val.add e#r (Vint n)); split; auto. +Qed. + +Lemma make_shlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shruimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. +Proof. + intros; unfold make_shruimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mulimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_mulimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. +Proof. + intros; unfold make_mulimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) eqn:?; intros. + rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. + econstructor; split; eauto. simpl. rewrite H; auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + destruct (Int.ltu i (Int.repr 31)) eqn:?. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_andimm_correct: + forall n r x, + vmatch bc e#r x -> + let (op, args) := make_andimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. +Proof. + intros; unfold make_andimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. + destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero + | _ => false end) eqn:UNS. + destruct x; try congruence. + exists (e#r); split; auto. + inv H; auto. simpl. replace (Int.and i n) with i; auto. + generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. + Int.bit_solve. destruct (zlt i0 n0). + replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). + rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite Int.bits_not by auto. apply negb_involutive. + rewrite H6 by auto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orimm_correct: + forall n r, + let (op, args) := make_orimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. +Proof. + intros; unfold make_orimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorimm_correct: + forall n r, + let (op, args) := make_xorimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. +Proof. + intros; unfold make_xorimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Val.notint e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_addlimm_correct: + forall n r, + let (op, args) := make_addlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. +Proof. + intros. unfold make_addlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. + destruct Archi.ptr64; auto. + exists (Val.addl e#r (Vlong n)); split; auto. +Qed. + +Lemma make_shllimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shllimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v. +Proof. + intros; unfold make_shllimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrluimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrluimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrluimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mullimm_correct: + forall n r1 r2, + e#r2 = Vlong n -> + let (op, args) := make_mullimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v. +Proof. + intros; unfold make_mullimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. + exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto. + destruct (Int64.is_power2' n) eqn:?; intros. + exists (Val.shll e#r1 (Vint i)); split; auto. + destruct (e#r1); simpl; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.mul_pow2' by eauto. auto. + econstructor; split; eauto. simpl; rewrite H; auto. +Qed. + +Lemma make_divlimm_correct: + forall n r1 r2 v, + Val.divls e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divlimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divlimm. + destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. + rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divluimm_correct: + forall n r1 r2 v, + Val.divlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divluimm. + destruct (Int64.is_power2' n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + exists v; auto. +Qed. + +Lemma make_modluimm_correct: + forall n r1 r2 v, + Val.modlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_modluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_modluimm. + destruct (Int64.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. erewrite Int64.modu_and by eauto. auto. + exists v; auto. +Qed. + +Lemma make_andlimm_correct: + forall n r x, + let (op, args) := make_andlimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v. +Proof. + intros; unfold make_andlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orlimm_correct: + forall n r, + let (op, args) := make_orlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v. +Proof. + intros; unfold make_orlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorlimm_correct: + forall n r, + let (op, args) := make_xorlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v. +Proof. + intros; unfold make_xorlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Val.notl e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_mulfimm_correct: + forall n r1 r2, + e#r2 = Vfloat n -> + let (op, args) := make_mulfimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfimm_correct_2: + forall n r1 r2, + e#r1 = Vfloat n -> + let (op, args) := make_mulfimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. + rewrite Float.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct: + forall n r1 r2, + e#r2 = Vsingle n -> + let (op, args) := make_mulfsimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct_2: + forall n r1 r2, + e#r1 = Vsingle n -> + let (op, args) := make_mulfsimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. + rewrite Float32.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_cast8signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast8signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. +Proof. + intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 8)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast16signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast16signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. +Proof. + intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 16)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma op_strength_reduction_correct: + forall op args vl v, + vl = map (fun r => AE.get r ae) args -> + eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v -> + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w. +Proof. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +- (* cast8signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. +- (* cast16signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. +- (* add 1 *) + rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* add 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* sub *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +- (* mul 1 *) + rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* mul 2*) + InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* divs *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divimm_correct; auto. +- (* divu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divuimm_correct; auto. +- (* modu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_moduimm_correct; auto. +- (* and 1 *) + rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* and 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* andimm *) + inv H; inv H0. apply make_andimm_correct; auto. +- (* or 1 *) + rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* or 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* xor 1 *) + rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* xor 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* shl *) + InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. +- (* shr *) + InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. +- (* shru *) + InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. +- (* addl 1 *) + rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* addl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* subl *) + InvApproxRegs; SimplVM; inv H0. + replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))). + apply make_addlimm_correct; auto. + unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto. + rewrite Int64.sub_add_opp; auto. + rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. + rewrite Int64.sub_add_opp; auto. +- (* mull 1 *) + rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* mull 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* divl *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divlimm_correct; auto. +- (* divlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divluimm_correct; auto. +- (* modlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_modluimm_correct; auto. +- (* andl 1 *) + rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andlimm *) + inv H; inv H0. apply make_andlimm_correct; auto. +- (* orl 1 *) + rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* orl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* xorl 1 *) + rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* xorl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* shll *) + InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. +- (* shrl *) + InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. +- (* shrlu *) + InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. +- (* cond *) + inv H0. apply make_cmp_correct; auto. +- (* mulf 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. +- (* mulf 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). + rewrite <- H2. apply make_mulfimm_correct_2; auto. +- (* mulfs 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. +- (* mulfs 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). + rewrite <- H2. apply make_mulfsimm_correct_2; auto. +- (* default *) + exists v; auto. +Qed. + +Lemma addr_strength_reduction_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction addr args vl in + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + intros until res. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; + intros VL EA; InvApproxRegs; SimplVM; try (inv EA). +- destruct (Archi.pic_code tt). ++ exists (Val.offset_ptr e#r1 n); auto. ++ simpl. rewrite Genv.shift_symbol_address. econstructor; split; eauto. + inv H0; simpl; auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + change (Vptr sp (Ptrofs.add n1 n)) with (Val.offset_ptr (Vptr sp n1) n). + inv H0; simpl; auto. +- exists res; auto. +Qed. + +End STRENGTH_REDUCTION. diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v new file mode 100644 index 00000000..df7ddfd2 --- /dev/null +++ b/mppa_k1c/Conventions1.v @@ -0,0 +1,441 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib Decidableplus. +Require Import AST Machregs Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Callee-save registers, whose value is preserved across a function call. +- Caller-save registers that can be modified during a function call. + + We follow the RISC-V application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition is_callee_save (r: mreg) : bool := + match r with + | R5 | R6 | R7 => false + | R8 | R9 => true + | R10 | R11 | R12 | R13 | R14 | R15 | R16 | R17 => false + | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 => true + | R28 | R29 | R30 => false + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 => false + | F8 | F9 => true + | F10 | F11 | F12 | F13 | F14 | F15 | F16 | F17 => false + | F18 | F19 | F20 | F21 | F22 | F23 | F24 | F25 | F26 | F27 => true + | F28 | F29 | F30 | F31 => false + end. + +Definition int_caller_save_regs := + R5 :: R6 :: R7 :: + R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: + R28 :: R29 :: R30 :: + nil. + +Definition float_caller_save_regs := + F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: + F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: + F28 :: F29 :: F30 :: F31 :: + nil. + +Definition int_callee_save_regs := + R8 :: R9 :: + R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: + nil. + +Definition float_callee_save_regs := + F8 :: F9 :: + F18 :: F19 :: F20 :: F21 :: F22 :: F23 :: F24 :: F25 :: F26 :: F27 :: + nil. + +Definition destroyed_at_call := + List.filter (fun r => negb (is_callee_save r)) all_mregs. + +Definition dummy_int_reg := R6. (**r Used in [Coloring]. *) +Definition dummy_float_reg := F0 . (**r Used in [Coloring]. *) + +Definition callee_save_type := mreg_type. + +Definition is_float_reg (r: mreg) := + match r with + | R5 | R6 | R7 | R8 | R9 | R10 | R11 + | R12 | R13 | R14 | R15 | R16 | R17 | R18 | R19 + | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 + | R28 | R29 | R30 => false + + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 + | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true + end. + +(** * Function calling conventions *) + +(** The functions in this section determine the locations (machine registers + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another compiler, we + implement the standard RISC-V conventions. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R10] or [F10] or [R10,R11], depending on the type of the + returned value. We treat a function without result as a function + with one integer result. *) + +Definition loc_result (s: signature) : rpair mreg := + match s.(sig_res) with + | None => One R10 + | Some (Tint | Tany32) => One R10 + | Some (Tfloat | Tsingle | Tany64) => One F10 + | Some Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10 + end. + +(** The result registers have types compatible with that given in the signature. *) + +Lemma loc_result_type: + forall sig, + subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. +Proof. + intros. unfold proj_sig_res, loc_result, mreg_type; + destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto. +Qed. + +(** The result locations are caller-save registers *) + +Lemma loc_result_caller_save: + forall (s: signature), + forall_rpair (fun r => is_callee_save r = false) (loc_result s). +Proof. + intros. unfold loc_result, is_callee_save; + destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto. +Qed. + +(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) + +Lemma loc_result_pair: + forall sg, + match loc_result sg with + | One _ => True + | Twolong r1 r2 => + r1 <> r2 /\ sg.(sig_res) = Some Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.ptr64 = false + end. +Proof. + intros. + unfold loc_result; destruct (sig_res sg) as [[]|]; auto. + unfold mreg_type; destruct Archi.ptr64; auto. + split; auto. congruence. +Qed. + +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result. rewrite H; auto. +Qed. + +(** ** Location of function arguments *) + +(** The RISC-V ABI states the following convention for passing arguments + to a function: + +- Arguments are passed in registers when possible. + +- Up to eight integer registers (ai: int_param_regs) and up to eight + floating-point registers (fai: float_param_regs) are used for this + purpose. + +- If the arguments to a function are conceptualized as fields of a C + struct, each with pointer alignment, the argument registers are a + shadow of the first eight pointer-words of that struct. If argument + i < 8 is a floating-point type, it is passed in floating-point + register fa_i; otherwise, it is passed in integer register a_i. + +- When primitive arguments twice the size of a pointer-word are passed + on the stack, they are naturally aligned. When they are passed in the + integer registers, they reside in an aligned even-odd register pair, + with the even register holding the least-significant bits. + +- Floating-point arguments to variadic functions (except those that + are explicitly named in the parameter list) are passed in integer + registers. + +- The portion of the conceptual struct that is not passed in argument + registers is passed on the stack. The stack pointer sp points to the + first argument not passed in a register. + +The bit about variadic functions doesn't quite fit CompCert's model. +We do our best by passing the FP arguments in registers, as usual, +and reserving the corresponding integer registers, so that fixup +code can be introduced in the Asmexpand pass. +*) + +Definition int_param_regs := + R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. +Definition float_param_regs := + F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: nil. + +Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + match list_nth_z regs rn with + | Some r => + One(R r) :: rec (rn + 1) ofs + | None => + let ofs := align ofs (typealign ty) in + One(S Outgoing ofs ty) :: rec rn (ofs + (if Archi.ptr64 then 2 else typesize ty)) + end. + +Definition two_args (regs: list mreg) (rn: Z) (ofs: Z) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn, list_nth_z regs (rn + 1) with + | Some r1, Some r2 => + Twolong (R r2) (R r1) :: rec (rn + 2) ofs + | _, _ => + let ofs := align ofs 2 in + Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) :: + rec rn (ofs + 2) + end. + +Definition hybrid_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn with + | Some r => + One (R r) :: rec (rn + 2) ofs + | None => + let ofs := align ofs 2 in + One (S Outgoing ofs ty) :: rec rn (ofs + 2) + end. + +Fixpoint loc_arguments_rec (va: bool) + (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | (Tint | Tany32) as ty :: tys => + one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + | Tsingle as ty :: tys => + one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + | Tlong as ty :: tys => + if Archi.ptr64 + then one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + else two_args int_param_regs r ofs (loc_arguments_rec va tys) + | (Tfloat | Tany64) as ty :: tys => + if va && negb Archi.ptr64 + then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + end. + +(** [loc_arguments s] returns the list of locations where to store arguments + when calling a function with signature [s]. *) + +Definition loc_arguments (s: signature) : list (rpair loc) := + loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Definition max_outgoing_1 (accu: Z) (l: loc) : Z := + match l with + | S Outgoing ofs ty => Z.max accu (ofs + typesize ty) + | _ => accu + end. + +Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z := + match rl with + | One l => max_outgoing_1 accu l + | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2 + end. + +Definition size_arguments (s: signature) : Z := + List.fold_left max_outgoing_2 (loc_arguments s) 0. + +(** Argument locations are either non-temporary registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => is_callee_save r = false + | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) + | _ => False + end. + +Lemma loc_arguments_rec_charact: + forall va tyl rn ofs p, + ofs >= 0 -> + In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p. +Proof. + set (OK := fun (l: list (rpair loc)) => + forall p, In p l -> forall_rpair loc_argument_acceptable p). + set (OKF := fun (f: Z -> Z -> list (rpair loc)) => + forall rn ofs, ofs >= 0 -> OK (f rn ofs)). + set (OKREGS := fun (l: list mreg) => forall r, In r l -> is_callee_save r = false). + assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0). + { intros. + assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos). + omega. } + assert (SK: (if Archi.ptr64 then 2 else 1) > 0). + { destruct Archi.ptr64; omega. } + assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0). + { intros. destruct Archi.ptr64. omega. apply typesize_pos. } + assert (A: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (one_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO; red; unfold one_arg; intros. + destruct (list_nth_z regs rn) as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. auto using align_divides, typealign_pos. + - eapply OF; [idtac|eauto]. + generalize (AL ofs ty OO) (SKK ty); omega. + } + assert (B: forall regs rn ofs f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (two_args regs rn ofs f)). + { intros until f; intros OR OF OO; unfold two_args. + set (rn' := align rn 2). + set (ofs' := align ofs 2). + assert (OO': ofs' >= 0) by (apply (AL ofs Tlong); auto). + assert (DFL: OK (Twolong (S Outgoing (ofs' + 1) Tint) (S Outgoing ofs' Tint) + :: f rn' (ofs' + 2))). + { red; simpl; intros. destruct H. + - subst p; simpl. + repeat split; auto using Z.divide_1_l. omega. + - eapply OF; [idtac|eauto]. omega. + } + destruct (list_nth_z regs rn') as [r1|] eqn:NTH1; + destruct (list_nth_z regs (rn' + 1)) as [r2|] eqn:NTH2; + try apply DFL. + red; simpl; intros; destruct H. + - subst p; simpl. split; apply OR; eauto using list_nth_z_in. + - eapply OF; [idtac|eauto]. auto. + } + assert (C: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> typealign ty = 1 -> OK (hybrid_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO OTY; unfold hybrid_arg; red; intros. + set (rn' := align rn 2) in *. + destruct (list_nth_z regs rn') as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l. + - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega. + } + assert (D: OKREGS int_param_regs). + { red. decide_goal. } + assert (E: OKREGS float_param_regs). + { red. decide_goal. } + + cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). + unfold OK. eauto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. +- red; simpl; tauto. +- destruct ty1. ++ (* int *) apply A; auto. ++ (* float *) + destruct (va && negb Archi.ptr64). + apply C; auto. + apply A; auto. ++ (* long *) + destruct Archi.ptr64. + apply A; auto. + apply B; auto. ++ (* single *) + apply A; auto. ++ (* any32 *) + apply A; auto. ++ (* any64 *) + destruct (va && negb Archi.ptr64). + apply C; auto. + apply A; auto. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (p: rpair loc), + In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. +Proof. + unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega. +Qed. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark fold_max_outgoing_above: + forall l n, fold_left max_outgoing_2 l n >= n. +Proof. + assert (A: forall n l, max_outgoing_1 n l >= n). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + induction l; simpl; intros. + - omega. + - eapply Zge_trans. eauto. + destruct a; simpl. apply A. eapply Zge_trans; eauto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros. apply fold_max_outgoing_above. +Qed. + +Lemma loc_arguments_bounded: + forall (s: signature) (ofs: Z) (ty: typ), + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> + ofs + typesize ty <= size_arguments s. +Proof. + intros until ty. + assert (A: forall n l, n <= max_outgoing_1 n l). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + assert (B: forall p n, + In (S Outgoing ofs ty) (regs_of_rpair p) -> + ofs + typesize ty <= max_outgoing_2 n p). + { intros. destruct p; simpl in H; intuition; subst; simpl. + - xomega. + - eapply Z.le_trans. 2: apply A. xomega. + - xomega. } + assert (C: forall l n, + In (S Outgoing ofs ty) (regs_of_rpairs l) -> + ofs + typesize ty <= fold_left max_outgoing_2 l n). + { induction l; simpl; intros. + - contradiction. + - rewrite in_app_iff in H. destruct H. + + eapply Z.le_trans. eapply B; eauto. apply Z.ge_le. apply fold_max_outgoing_above. + + apply IHl; auto. + } + apply C. +Qed. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + reflexivity. +Qed. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v new file mode 100644 index 00000000..d8bb4a4b --- /dev/null +++ b/mppa_k1c/Machregs.v @@ -0,0 +1,253 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +Require Import String. +Require Import Coqlib. +Require Import Decidableplus. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Op. + +(** ** Machine registers *) + +(** The following type defines the machine registers that can be referenced + as locations. These include: +- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). +- Floating-point registers that can be allocated to RTL pseudo-registers + ([Fxx]). + + The type [mreg] does not include reserved machine registers such as + the zero register (x0), the link register (x1), the stack pointer + (x2), the global pointer (x3), and the thread pointer (x4). + Finally, register x31 is reserved for use as a temporary by the + assembly-code generator [Asmgen]. +*) + +Inductive mreg: Type := + (** Allocatable integer regs. *) + | R5: mreg | R6: mreg | R7: mreg + | R8: mreg | R9: mreg | R10: mreg | R11: mreg + | R12: mreg | R13: mreg | R14: mreg | R15: mreg + | R16: mreg | R17: mreg | R18: mreg | R19: mreg + | R20: mreg | R21: mreg | R22: mreg | R23: mreg + | R24: mreg | R25: mreg | R26: mreg | R27: mreg + | R28: mreg | R29: mreg | R30: mreg + (** Allocatable double-precision float regs *) + | F0: mreg | F1: mreg | F2: mreg | F3: mreg + | F4: mreg | F5: mreg | F6: mreg | F7: mreg + | F8: mreg | F9: mreg | F10: mreg | F11: mreg + | F12: mreg | F13: mreg | F14: mreg | F15: mreg + | F16: mreg | F17: mreg | F18: mreg | F19: mreg + | F20: mreg | F21: mreg | F22: mreg | F23: mreg + | F24: mreg | F25: mreg | F26: mreg | F27: mreg + | F28: mreg | F29: mreg | F30: mreg | F31: mreg. + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Defined. +Global Opaque mreg_eq. + +Definition all_mregs := + R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15 + :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 + :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 + :: F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 + :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 + :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23 + :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 + :: nil. + +Lemma all_mregs_complete: + forall (r: mreg), In r all_mregs. +Proof. + assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). + intros. specialize (H r). InvBooleans. auto. +Qed. + +Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. + +Instance Finite_mreg : Finite mreg := { + Finite_elements := all_mregs; + Finite_elements_spec := all_mregs_complete +}. + +Definition mreg_type (r: mreg): typ := + match r with + | R5 | R6 | R7 | R8 | R9 | R10 | R11 + | R12 | R13 | R14 | R15 | R16 | R17 | R18 | R19 + | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 + | R28 | R29 | R30 => if Archi.ptr64 then Tany64 else Tany32 + + | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 + | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 + | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 + | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => Tany64 + end. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + Definition eq := mreg_eq. + Definition index (r: mreg): positive := + match r with + | R5 => 1 | R6 => 2 | R7 => 3 + | R8 => 4 | R9 => 5 | R10 => 6 | R11 => 7 + | R12 => 8 | R13 => 9 | R14 => 10 | R15 => 11 + | R16 => 12 | R17 => 13 | R18 => 14 | R19 => 15 + | R20 => 16 | R21 => 17 | R22 => 18 | R23 => 19 + | R24 => 20 | R25 => 21 | R26 => 22 | R27 => 23 + | R28 => 24 | R29 => 25 | R30 => 26 + + | F0 => 28 | F1 => 29 | F2 => 30 | F3 => 31 + | F4 => 32 | F5 => 33 | F6 => 34 | F7 => 35 + | F8 => 36 | F9 => 37 | F10 => 38 | F11 => 39 + | F12 => 40 | F13 => 41 | F14 => 42 | F15 => 43 + | F16 => 44 | F17 => 45 | F18 => 46 | F19 => 47 + | F20 => 48 | F21 => 49 | F22 => 50 | F23 => 51 + | F24 => 52 | F25 => 53 | F26 => 54 | F27 => 55 + | F28 => 56 | F29 => 57 | F30 => 58 | F31 => 59 + end. + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + decide_goal. + Qed. +End IndexedMreg. + +Definition is_stack_reg (r: mreg) : bool := false. + +(** ** Names of registers *) + +Local Open Scope string_scope. + +Definition register_names := + ("X5", R5) :: ("X6", R6) :: ("X7", R7) :: + ("X8", R8) :: ("X9", R9) :: ("X10", R10) :: ("X11", R11) :: + ("X12", R12) :: ("X13", R13) :: ("X14", R14) :: ("X15", R15) :: + ("X16", R16) :: ("X17", R17) :: ("X18", R18) :: ("X19", R19) :: + ("X20", R20) :: ("X21", R21) :: ("X22", R22) :: ("X23", R23) :: + ("X24", R24) :: ("X25", R25) :: ("X26", R26) :: ("X27", R27) :: + ("X28", R28) :: ("X29", R29) :: ("X30", R30) :: + + ("F0", F0) :: ("F1", F1) :: ("F2", F2) :: ("F3", F3) :: + ("F4", F4) :: ("F5", F5) :: ("F6", F6) :: ("F7", F7) :: + ("F8", F8) :: ("F9", F9) :: ("F10", F10) :: ("F11", F11) :: + ("F12", F12) :: ("F13", F13) :: ("F14", F14) :: ("F15", F15) :: + ("F16", F16) :: ("F17", F17) :: ("F18", F18) :: ("F19", F19) :: + ("F20", F20) :: ("F21", F21) :: ("F22", F22) :: ("F23", F23) :: + ("F24", F24) :: ("F25", F25) :: ("F26", F26) :: ("F27", F27) :: + ("F28", F28) :: ("F29", F29) :: ("F30", F30) :: ("F31", F31) :: + nil. + +Definition register_by_name (s: string) : option mreg := + let fix assoc (l: list (string * mreg)) : option mreg := + match l with + | nil => None + | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' + end + in assoc register_names. + +(** ** Destroyed registers, preferred registers *) + +Definition destroyed_by_op (op: operation): list mreg := + match op with + | Ointoffloat | Ointuoffloat | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle + => F6 :: nil + | _ => nil + end. + +Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_cond (cond: condition): list mreg := nil. + +Definition destroyed_by_jumptable: list mreg := R5 :: nil. + +Fixpoint destroyed_by_clobber (cl: list string): list mreg := + match cl with + | nil => nil + | c1 :: cl => + match register_by_name c1 with + | Some r => r :: destroyed_by_clobber cl + | None => destroyed_by_clobber cl + end + end. + +Definition destroyed_by_builtin (ef: external_function): list mreg := + match ef with + | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil + | _ => nil + end. + +Definition destroyed_by_setstack (ty: typ): list mreg := nil. + +Definition destroyed_at_function_entry: list mreg := R30 :: nil. + +Definition temp_for_parent_frame: mreg := R30. + +Definition destroyed_at_indirect_call: list mreg := + R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. + +Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). + +Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := + match ef with + | EF_builtin name sg => + if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then + (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) + else + (nil, nil) + | _ => + (nil, nil) + end. + +Global Opaque + destroyed_by_op destroyed_by_load destroyed_by_store + destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin + destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame + mregs_for_operation mregs_for_builtin. + +(** Two-address operations. Return [true] if the first argument and + the result must be in the same location *and* are unconstrained + by [mregs_for_operation]. There are two: the pseudo [Ocast32signed], + because it expands to a no-op owing to the representation of 32-bit + integers as their 64-bit sign extension; and [Ocast32unsigned], + because it builds on the same magic no-op. *) + +Definition two_address_op (op: operation) : bool := + match op with + | Ocast32signed | Ocast32unsigned => true + | _ => false + end. + +(** Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_builtin id sg => nil + | EF_vload _ => OK_addressing :: nil + | EF_vstore _ => OK_addressing :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot kind txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/mppa_k1c/Machregsaux.ml b/mppa_k1c/Machregsaux.ml new file mode 100644 index 00000000..473e0602 --- /dev/null +++ b/mppa_k1c/Machregsaux.ml @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +open Camlcoq +open Machregs + +let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 + +let _ = + List.iter + (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) + Machregs.register_names + +let is_scratch_register r = false + +let name_of_register r = + try Some (Hashtbl.find register_names r) with Not_found -> None + +let register_by_name s = + Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) + +let can_reserve_register r = Conventions1.is_callee_save r diff --git a/mppa_k1c/Machregsaux.mli b/mppa_k1c/Machregsaux.mli new file mode 100644 index 00000000..9404568d --- /dev/null +++ b/mppa_k1c/Machregsaux.mli @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +val name_of_register: Machregs.mreg -> string option +val register_by_name: string -> Machregs.mreg option +val is_scratch_register: string -> bool +val can_reserve_register: Machregs.mreg -> bool diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v new file mode 100644 index 00000000..117bbcb4 --- /dev/null +++ b/mppa_k1c/NeedOp.v @@ -0,0 +1,173 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs. +Require Import Op RTL. +Require Import NeedDomain. + +(** Neededness analysis for RISC-V operators *) + +Definition op1 (nv: nval) := nv :: nil. +Definition op2 (nv: nval) := nv :: nv :: nil. + +Definition needs_of_condition (cond: condition): list nval := nil. + +Definition needs_of_operation (op: operation) (nv: nval): list nval := + match op with + | Omove => op1 nv + | Ointconst n => nil + | Olongconst n => nil + | Ofloatconst n => nil + | Osingleconst n => nil + | Oaddrsymbol id ofs => nil + | Oaddrstack ofs => nil + | Ocast8signed => op1 (sign_ext 8 nv) + | Ocast16signed => op1 (sign_ext 16 nv) + | Oadd => op2 (modarith nv) + | Oaddimm n => op1 (modarith nv) + | Oneg => op1 (modarith nv) + | Osub => op2 (default nv) + | Omul => op2 (modarith nv) + | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) + | Oand => op2 (bitwise nv) + | Oandimm n => op1 (andimm nv n) + | Oor => op2 (bitwise nv) + | Oorimm n => op1 (orimm nv n) + | Oxor => op2 (bitwise nv) + | Oxorimm n => op1 (bitwise nv) + | Oshl | Oshr | Oshru => op2 (default nv) + | Oshlimm n => op1 (shlimm nv n) + | Oshrimm n => op1 (shrimm nv n) + | Oshruimm n => op1 (shruimm nv n) + | Oshrximm n => op1 (default 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) + | Onegl => op1 (default nv) + | Osubl => op2 (default nv) + | Omull => op2 (default nv) + | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) + | Oandl => op2 (default nv) + | Oandlimm n => op1 (default nv) + | Oorl => op2 (default nv) + | Oorlimm n => op1 (default nv) + | Oxorl => op2 (default nv) + | Oxorlimm n => op1 (default nv) + | Oshll | Oshrl | Oshrlu => op2 (default nv) + | Oshllimm n => op1 (default nv) + | Oshrlimm n => op1 (default nv) + | Oshrluimm n => op1 (default nv) + | Oshrxlimm n => op1 (default nv) + | Onegf | Oabsf => op1 (default nv) + | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) + | Onegfs | Oabsfs => op1 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Ofloatofsingle | Osingleoffloat => op1 (default nv) + | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => 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 + end. + +Definition operation_is_redundant (op: operation) (nv: nval): bool := + match op with + | Ocast8signed => sign_ext_redundant 8 nv + | Ocast16signed => sign_ext_redundant 16 nv + | Oandimm n => andimm_redundant nv n + | Oorimm n => orimm_redundant nv n + | _ => false + end. + +Ltac InvAgree := + match goal with + | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree + | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree + | _ => idtac + end. + +Ltac TrivialExists := + match goal with + | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto + | _ => idtac + end. + +Section SOUNDNESS. + +Variable ge: genv. +Variable sp: block. +Variables m m': mem. +Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. + +Lemma needs_of_condition_sound: + forall cond args b args', + eval_condition cond args m = Some b -> + vagree_list args args' (needs_of_condition cond) -> + eval_condition cond args' m' = Some b. +Proof. + intros. unfold needs_of_condition in H0. + eapply default_needs_of_condition_sound; eauto. +Qed. + +Lemma needs_of_operation_sound: + forall op args v nv args', + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> + vagree_list args args' (needs_of_operation op nv) -> + nv <> Nothing -> + exists v', + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' + /\ vagree v v' nv. +Proof. + unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); + simpl in *; FuncInv; InvAgree; TrivialExists. +- apply sign_ext_sound; auto. compute; auto. +- apply sign_ext_sound; auto. compute; auto. +- apply add_sound; auto. +- apply add_sound; auto with na. +- apply neg_sound; auto. +- apply mul_sound; auto. +- apply and_sound; auto. +- apply andimm_sound; auto. +- apply or_sound; auto. +- apply orimm_sound; auto. +- apply xor_sound; auto. +- apply xor_sound; auto with na. +- apply shlimm_sound; auto. +- apply shrimm_sound; auto. +- apply shruimm_sound; auto. +Qed. + +Lemma operation_is_redundant_sound: + forall op nv arg1 args v arg1' args', + operation_is_redundant op nv = true -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> + vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> + vagree v arg1' nv. +Proof. + intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. +- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. omega. +- apply andimm_redundant_sound; auto. +- apply orimm_redundant_sound; auto. +Qed. + +End SOUNDNESS. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v new file mode 100644 index 00000000..bb04f786 --- /dev/null +++ b/mppa_k1c/Op.v @@ -0,0 +1,1361 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + semantics for the CminorSel, RTL, LTL and Mach languages depend on the + following types, defined in this library: +- [condition]: boolean conditions for conditional branches; +- [operation]: arithmetic and logical operations; +- [addressing]: addressing modes for load and store operations. + + These types are processor-specific and correspond roughly to what the + processor can compute in one instruction. In other terms, these + types reflect the state of the program after instruction selection. + For a processor-independent set of operations, see the abstract + syntax and dynamic semantics of the Cminor language. +*) + +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. + +Set Implicit Arguments. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Type := + | Ccomp (c: comparison) (**r signed integer comparison *) + | Ccompu (c: comparison) (**r unsigned integer comparison *) + | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) + | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) + | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) + | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) + | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) + | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) + | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) + | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) + | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) + | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Type := + | Omove (**r [rd = r1] *) + | Ointconst (n: int) (**r [rd] is set to the given integer constant *) + | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) + | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) + | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) + | Oaddrsymbol (id: ident) (ofs: ptrofs) (**r [rd] is set to the address of the symbol plus the given offset *) + | Oaddrstack (ofs: ptrofs) (**r [rd] is set to the stack pointer plus the given offset *) +(*c 32-bit integer arithmetic: *) + | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) + | Oadd (**r [rd = r1 + r2] *) + | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oneg (**r [rd = - r1] *) + | Osub (**r [rd = r1 - r2] *) + | Omul (**r [rd = r1 * r2] *) + | Omulhs (**r [rd = high part of r1 * r2, signed] *) + | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odiv (**r [rd = r1 / r2] (signed) *) + | Odivu (**r [rd = r1 / r2] (unsigned) *) + | Omod (**r [rd = r1 % r2] (signed) *) + | Omodu (**r [rd = r1 % r2] (unsigned) *) + | Oand (**r [rd = r1 & r2] *) + | Oandimm (n: int) (**r [rd = r1 & n] *) + | Oor (**r [rd = r1 | r2] *) + | Oorimm (n: int) (**r [rd = r1 | n] *) + | Oxor (**r [rd = r1 ^ r2] *) + | Oxorimm (n: int) (**r [rd = r1 ^ n] *) + | 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) *) + | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) +(*c 64-bit integer arithmetic: *) + | Omakelong (**r [rd = r1 << 32 | r2] *) + | Olowlong (**r [rd = low-word(r1)] *) + | Ohighlong (**r [rd = high-word(r1)] *) + | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) + | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) + | Oaddl (**r [rd = r1 + r2] *) + | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Onegl (**r [rd = - r1] *) + | Osubl (**r [rd = r1 - r2] *) + | Omull (**r [rd = r1 * r2] *) + | Omullhs (**r [rd = high part of r1 * r2, signed] *) + | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odivl (**r [rd = r1 / r2] (signed) *) + | Odivlu (**r [rd = r1 / r2] (unsigned) *) + | Omodl (**r [rd = r1 % r2] (signed) *) + | Omodlu (**r [rd = r1 % r2] (unsigned) *) + | Oandl (**r [rd = r1 & r2] *) + | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Oorl (**r [rd = r1 | r2] *) + | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Oxorl (**r [rd = r1 ^ r2] *) + | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Oshll (**r [rd = r1 << r2] *) + | Oshllimm (n: int) (**r [rd = r1 << n] *) + | Oshrl (**r [rd = r1 >> r2] (signed) *) + | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) + | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) +(*c Floating-point arithmetic: *) + | Onegf (**r [rd = - r1] *) + | Oabsf (**r [rd = abs(r1)] *) + | Oaddf (**r [rd = r1 + r2] *) + | Osubf (**r [rd = r1 - r2] *) + | Omulf (**r [rd = r1 * r2] *) + | Odivf (**r [rd = r1 / r2] *) + | Onegfs (**r [rd = - r1] *) + | Oabsfs (**r [rd = abs(r1)] *) + | Oaddfs (**r [rd = r1 + r2] *) + | Osubfs (**r [rd = r1 - r2] *) + | Omulfs (**r [rd = r1 * r2] *) + | Odivfs (**r [rd = r1 / r2] *) + | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (**r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (**r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (**r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (**r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (**r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Type := + | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) + | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in modules [CSE] and [Allocation]). *) + +Definition eq_condition (x y: condition) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize ident_eq Ptrofs.eq_dec; intros. + 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; intros. + decide equality. +Defined. + +(* Alternate definition: +Definition beq_operation: forall (x y: operation), bool. +Proof. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; boolean_equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + decidable_equality_from beq_operation. +Defined. +*) + +Global Opaque eq_condition eq_addressing eq_operation. + +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) + | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) + | _, _ => None + end. + +Definition eval_operation + (F V: Type) (genv: Genv.t F V) (sp: val) + (op: operation) (vl: list val) (m: mem): option val := + match op, vl with + | Omove, v1::nil => Some v1 + | Ointconst n, nil => Some (Vint n) + | Olongconst n, nil => Some (Vlong n) + | Ofloatconst n, nil => Some (Vfloat n) + | Osingleconst n, nil => Some (Vsingle n) + | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | 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)) + | Oneg, v1 :: nil => Some (Val.neg v1) + | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) + | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) + | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 + | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Omod, v1 :: v2 :: nil => Val.mods v1 v2 + | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 + | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) + | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) + | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) + | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) + | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) + | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) + | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) + | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) + | Olowlong, v1::nil => Some (Val.loword v1) + | Ohighlong, v1::nil => Some (Val.hiword v1) + | Ocast32signed, v1 :: nil => Some (Val.longofint v1) + | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) + | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Onegl, v1::nil => Some (Val.negl v1) + | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Omull, v1::v2::nil => Some (Val.mull v1 v2) + | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) + | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) + | Odivl, v1::v2::nil => Val.divls v1 v2 + | Odivlu, v1::v2::nil => Val.divlu v1 v2 + | Omodl, v1::v2::nil => Val.modls v1 v2 + | Omodlu, v1::v2::nil => Val.modlu v1 v2 + | Oandl, v1::v2::nil => Some(Val.andl v1 v2) + | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) + | Oorl, v1::v2::nil => Some(Val.orl v1 v2) + | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) + | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) + | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | Oshll, v1::v2::nil => Some (Val.shll v1 v2) + | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) + | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) + | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) + | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) + | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) + | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) + | Onegf, v1::nil => Some (Val.negf v1) + | Oabsf, v1::nil => Some (Val.absf v1) + | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) + | Osubf, v1::v2::nil => Some (Val.subf v1 v2) + | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + | Onegfs, v1::nil => Some (Val.negfs v1) + | Oabsfs, v1::nil => Some (Val.absfs v1) + | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) + | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) + | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) + | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) + | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ointofsingle, v1::nil => Val.intofsingle v1 + | Ointuofsingle, v1::nil => Val.intuofsingle v1 + | Osingleofint, v1::nil => Val.singleofint v1 + | Osingleofintu, v1::nil => Val.singleofintu v1 + | Olongoffloat, v1::nil => Val.longoffloat v1 + | Olonguoffloat, v1::nil => Val.longuoffloat v1 + | Ofloatoflong, v1::nil => Val.floatoflong v1 + | Ofloatoflongu, v1::nil => Val.floatoflongu v1 + | Olongofsingle, v1::nil => Val.longofsingle v1 + | Olonguofsingle, v1::nil => Val.longuofsingle v1 + | Osingleoflong, v1::nil => Val.singleoflong v1 + | Osingleoflongu, v1::nil => Val.singleoflongu v1 + | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + | _, _ => None + end. + +Definition eval_addressing + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) + | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Ainstack n, nil => Some (Val.offset_ptr sp n) + | _, _ => None + end. + +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. reflexivity. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing; intros; destruct vl; inv H; auto. +Qed. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; FuncInv + | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => + destruct Archi.ptr64 eqn:?; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | H: (None = Some _) |- _ => + discriminate H + | _ => + idtac + end. + +(** * Static typing of conditions, operators and addressing modes. *) + +Definition type_of_condition (c: condition) : list typ := + match c with + | Ccomp _ => Tint :: Tint :: nil + | Ccompu _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompl _ => Tlong :: Tlong :: nil + | Ccomplu _ => Tlong :: Tlong :: nil + | Ccomplimm _ _ => Tlong :: nil + | Ccompluimm _ _ => Tlong :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Ccompfs _ => Tsingle :: Tsingle :: nil + | Cnotcompfs _ => Tsingle :: Tsingle :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Olongconst _ => (nil, Tlong) + | Ofloatconst f => (nil, Tfloat) + | Osingleconst f => (nil, Tsingle) + | Oaddrsymbol _ _ => (nil, Tptr) + | Oaddrstack _ => (nil, Tptr) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Oneg => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omulhs => (Tint :: Tint :: nil, Tint) + | Omulhu => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Omod => (Tint :: Tint :: nil, Tint) + | Omodu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshlimm _ => (Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshrimm _ => (Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshruimm _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Omakelong => (Tint :: Tint :: nil, Tlong) + | Olowlong => (Tlong :: nil, Tint) + | Ohighlong => (Tlong :: nil, Tint) + | Ocast32signed => (Tint :: nil, Tlong) + | Ocast32unsigned => (Tint :: nil, Tlong) + | Oaddl => (Tlong :: Tlong :: nil, Tlong) + | Oaddlimm _ => (Tlong :: nil, Tlong) + | Onegl => (Tlong :: nil, Tlong) + | Osubl => (Tlong :: Tlong :: nil, Tlong) + | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omullhs => (Tlong :: Tlong :: nil, Tlong) + | Omullhu => (Tlong :: Tlong :: nil, Tlong) + | Odivl => (Tlong :: Tlong :: nil, Tlong) + | Odivlu => (Tlong :: Tlong :: nil, Tlong) + | Omodl => (Tlong :: Tlong :: nil, Tlong) + | Omodlu => (Tlong :: Tlong :: nil, Tlong) + | Oandl => (Tlong :: Tlong :: nil, Tlong) + | Oandlimm _ => (Tlong :: nil, Tlong) + | Oorl => (Tlong :: Tlong :: nil, Tlong) + | Oorlimm _ => (Tlong :: nil, Tlong) + | Oxorl => (Tlong :: Tlong :: nil, Tlong) + | Oxorlimm _ => (Tlong :: nil, Tlong) + | Oshll => (Tlong :: Tint :: nil, Tlong) + | Oshllimm _ => (Tlong :: nil, Tlong) + | Oshrl => (Tlong :: Tint :: nil, Tlong) + | Oshrlimm _ => (Tlong :: nil, Tlong) + | Oshrlu => (Tlong :: Tint :: nil, Tlong) + | Oshrluimm _ => (Tlong :: nil, Tlong) + | Oshrxlimm _ => (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) + | Onegfs => (Tsingle :: nil, Tsingle) + | Oabsfs => (Tsingle :: nil, Tsingle) + | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) + | Ofloatofsingle => (Tsingle :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ointofsingle => (Tsingle :: nil, Tint) + | Ointuofsingle => (Tsingle :: nil, Tint) + | Osingleofint => (Tint :: nil, Tsingle) + | Osingleofintu => (Tint :: nil, Tsingle) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Olonguoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Ofloatoflongu => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Olonguofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) + | Osingleoflongu => (Tlong :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tptr :: nil + | Aglobal _ _ => nil + | Ainstack _ => nil + end. + +(** Weak type soundness results for [eval_operation]: + the result values, when defined, are always of the type predicted + by [type_of_operation]. *) + +Section SOUNDNESS. + +Variable A V: Type. +Variable genv: Genv.t A V. + +Remark type_add: + forall v1 v2, Val.has_type (Val.add v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Remark type_addl: + forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Lemma type_of_operation_sound: + forall op vl sp v m, + op <> Omove -> + eval_operation genv sp op vl m = Some v -> + Val.has_type v (snd (type_of_operation op)). +Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + intros. + destruct op; simpl; simpl in H0; FuncInv; subst; simpl. + (* move *) + - congruence. + (* intconst, longconst, floatconst, singleconst *) + - exact I. + - exact I. + - exact I. + - exact I. + (* addrsymbol *) + - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... + (* addrstack *) + - destruct sp... apply Val.Vptr_has_type. + (* castsigned *) + - destruct v0... + - destruct v0... + (* add, addimm *) + - apply type_add. + - apply type_add. + (* neg, sub *) + - destruct v0... + - unfold Val.sub. destruct v0; destruct v1... + unfold Val.has_type; destruct Archi.ptr64... + destruct Archi.ptr64... destruct (eq_block b b0)... + (* mul, mulhs, mulhu *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* div, divu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* mod, modu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* and, andimm *) + - destruct v0; destruct v1... + - destruct v0... + (* or, orimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xor, xorimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shl, shlimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shrx *) + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + (* makelong, lowlong, highlong *) + - destruct v0; destruct v1... + - destruct v0... + - destruct v0... + (* cast32 *) + - destruct v0... + - destruct v0... + (* addl, addlimm *) + - apply type_addl. + - apply type_addl. + (* negl, subl *) + - destruct v0... + - unfold Val.subl. destruct v0; destruct v1... + unfold Val.has_type; destruct Archi.ptr64... + destruct Archi.ptr64... destruct (eq_block b b0)... + (* mull, mullhs, mullhu *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* divl, divlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* modl, modlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* andl, andlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* orl, orlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xorl, xorlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shll, shllimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shrxl *) + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + (* negf, absf *) + - destruct v0... + - destruct v0... + (* addf, subf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulf, divf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* negfs, absfs *) + - destruct v0... + - destruct v0... + (* addfs, subfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulfs, divfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* singleoffloat, floatofsingle *) + - destruct v0... + - destruct v0... + (* intoffloat, intuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + (* floatofint, floatofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* intofsingle, intuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + (* singleofint, singleofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longoffloat, longuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + (* floatoflong, floatoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longofsingle, longuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + (* singleoflong, singleoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* cmp *) + - destruct (eval_condition cond vl m)... destruct b... +Qed. + +End SOUNDNESS. + +(** * Manipulating and transforming operations *) + +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None + end. + +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompl c => Ccompl(negate_comparison c) + | Ccomplu c => Ccomplu(negate_comparison c) + | Ccomplimm c n => Ccomplimm (negate_comparison c) n + | Ccompluimm c n => Ccompluimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Ccompfs c => Cnotcompfs c + | Cnotcompfs c => Ccompfs c + end. + +Lemma eval_negate_condition: + forall cond vl m, + eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). +Proof. + intros. destruct cond; simpl. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: Z) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => addr + end. + +Definition shift_stack_operation (delta: Z) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. +Qed. + +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. destruct addr; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. +Proof. + intros. destruct op; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +(** Offset an addressing mode [addr] by a quantity [delta], so that + it designates the pointer [delta] bytes past the pointer designated + by [addr]. May be undefined, in which case [None] is returned. *) + +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := + match addr with + | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) + | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) + | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) + end. + +Lemma eval_offset_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, + offset_addressing addr delta = Some addr' -> + eval_addressing ge sp addr args = Some v -> + Archi.ptr64 = false -> + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). +Proof. + intros. + assert (A: forall x n, + Val.offset_ptr x (Ptrofs.add n (Ptrofs.repr delta)) = + Val.add (Val.offset_ptr x n) (Vint (Int.repr delta))). + { intros; destruct x; simpl; auto. rewrite H1. + rewrite Ptrofs.add_assoc. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. } + destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. +- rewrite A; auto. +- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. + simpl. rewrite H1. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. +- rewrite A; auto. +Qed. + +(** Operations that are so cheap to recompute that CSE should not factor them out. *) + +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst n => Int.eq (Int.sign_ext 12 n) n + | Olongconst n => Int64.eq (Int64.sign_ext 12 n) n + | Oaddrstack _ => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _) => negb Archi.ptr64 + | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 + | Ocmp (Ccomplu _) => Archi.ptr64 + | Ocmp (Ccompluimm _ _) => Archi.ptr64 + | _ => false + end. + +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + +(** Global variables mentioned in an operation or addressing mode *) + +Definition globals_addressing (addr: addressing) : list ident := + match addr with + | Aglobal s ofs => s :: nil + | _ => nil + end. + +Definition globals_operation (op: operation) : list ident := + match op with + | Oaddrsymbol s ofs => s :: nil + | _ => nil + end. + +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing; destruct addr; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. + unfold eval_operation; destruct op; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Variable f: meminj. + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: Val.inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ nil _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + Val.inject_list f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_operation op) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_operation ge1 sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + (* addrsymbol *) + - apply GL; simpl; auto. + (* addrstack *) + - apply Val.offset_ptr_inject; auto. + (* castsigned *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* add, addimm *) + - apply Val.add_inject; auto. + - apply Val.add_inject; auto. + (* neg, sub *) + - inv H4; simpl; auto. + - apply Val.sub_inject; auto. + (* mul, mulhs, mulhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* div, divu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* mod, modu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* and, andimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* or, orimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xor, xorimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shl, shlimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shru, shruimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shrx *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + (* makelong, highlong, lowlong *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* cast32 *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addl, addlimm *) + - apply Val.addl_inject; auto. + - apply Val.addl_inject; auto. + (* negl, subl *) + - inv H4; simpl; auto. + - apply Val.subl_inject; auto. + (* mull, mullhs, mullhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* divl, divlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* modl, modlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* andl, andlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* orl, orlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xorl, xorlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shll, shllimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shru, shruimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shrx *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + (* negf, absf *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addf, subf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulf, divf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* negfs, absfs *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addfs, subfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulfs, divfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* singleoffloat, floatofsingle *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* intoffloat, intuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* floatofint, floatofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* intofsingle, intuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* singleofint, singleofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longoffloat, longuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* floatoflong, floatoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longofsingle, longuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* singleoflong, singleoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* cmp *) + - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. + apply Val.offset_ptr_inject; auto. + apply H; simpl; auto. + apply Val.offset_ptr_inject; auto. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_list_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + intros. apply val_inject_lessdef. auto. + apply val_inject_lessdef; auto. + eauto. + auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +End EVAL_INJECT. + +(** * Handling of builtin arguments *) + +Definition builtin_arg_ok_1 + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match c, ba with + | OK_all, _ => true + | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true + | OK_addrstack, BA_addrstack _ => true + | OK_addressing, BA_addrstack _ => true + | OK_addressing, BA_addptr (BA _) (BA_int _) => true + | OK_addressing, BA_addptr (BA _) (BA_long _) => true + | _, _ => false + end. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba with + | (BA _ | BA_splitlong (BA _) (BA _)) => true + | _ => builtin_arg_ok_1 ba c + end. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml new file mode 100644 index 00000000..9ec474b3 --- /dev/null +++ b/mppa_k1c/PrintOp.ml @@ -0,0 +1,166 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Printf +open Camlcoq +open Integers +open Op + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let print_condition reg pp = function + | (Ccomp c, [r1;r2]) -> + fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 + | (Ccompu c, [r1;r2]) -> + fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 + | (Ccompimm(c, n), [r1]) -> + fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompuimm(c, n), [r1]) -> + fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Ccompl c, [r1;r2]) -> + fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 + | (Ccomplu c, [r1;r2]) -> + fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 + | (Ccomplimm(c, n), [r1]) -> + fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccompluimm(c, n), [r1]) -> + fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | (Ccompfs c, [r1;r2]) -> + fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 + | (Cnotcompfs c, [r1;r2]) -> + fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 + | _ -> + fprintf pp "" + +let print_operation reg pp = function + | Omove, [r1] -> reg pp r1 + | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) + | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 + | 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) + | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | 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 + | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 + | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 + | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) + | 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) + + | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 + | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 + | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 + | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 + | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 + | 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) + | 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 + | 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 + | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 + | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 + | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 + | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 + | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) + | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 + | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 + | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Oshll, [r1;r2] -> fprintf pp "%a < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) + | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 + | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) + | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + + | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 + | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 + | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 + | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 + | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 + | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 + | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1 + | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1 + | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2 + | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2 + | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2 + | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2 + | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 + | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 + | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%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 + | 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 "" + +let print_addressing reg pp = function + | 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) + | _ -> fprintf pp "" diff --git a/mppa_k1c/SelectLong.v b/mppa_k1c/SelectLong.v new file mode 100644 index 00000000..876d02fb --- /dev/null +++ b/mppa_k1c/SelectLong.v @@ -0,0 +1,778 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +(** Original definition: +<< +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) 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 (Oaddlimm n) (e ::: Enil) + end. +>> +*) + +Inductive addlimm_cases: forall (e: expr), Type := + | addlimm_case1: forall m, addlimm_cases (Eop (Olongconst m) Enil) + | addlimm_case2: forall s m, addlimm_cases (Eop (Oaddrsymbol s m) Enil) + | addlimm_case3: forall m, addlimm_cases (Eop (Oaddrstack m) Enil) + | addlimm_case4: forall m t, addlimm_cases (Eop (Oaddlimm m) (t ::: Enil)) + | addlimm_default: forall (e: expr), addlimm_cases e. + +Definition addlimm_match (e: expr) := + match e as zz1 return addlimm_cases zz1 with + | Eop (Olongconst m) Enil => addlimm_case1 m + | Eop (Oaddrsymbol s m) Enil => addlimm_case2 s m + | Eop (Oaddrstack m) Enil => addlimm_case3 m + | Eop (Oaddlimm m) (t ::: Enil) => addlimm_case4 m t + | e => addlimm_default e + end. + +Definition addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else match addlimm_match e with + | addlimm_case1 m => (* Eop (Olongconst m) Enil *) + longconst (Int64.add n m) + | addlimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) + Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | addlimm_case3 m => (* Eop (Oaddrstack m) Enil *) + Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | addlimm_case4 m t => (* Eop (Oaddlimm m) (t ::: Enil) *) + Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | addlimm_default e => + Eop (Oaddlimm n) (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. +>> +*) + +Inductive addl_cases: forall (e1: expr) (e2: expr), Type := + | addl_case1: forall n1 t2, addl_cases (Eop (Olongconst n1) Enil) (t2) + | addl_case2: forall t1 n2, addl_cases (t1) (Eop (Olongconst n2) Enil) + | addl_case3: forall n1 t1 n2 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_case4: forall n1 t1 n2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) + | addl_case5: forall n1 n2 t2, addl_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_case6: forall n1 t1 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) + | addl_case7: forall t1 n2 t2, addl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_default: forall (e1: expr) (e2: expr), addl_cases e1 e2. + +Definition addl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return addl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => addl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => addl_case2 t1 n2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => addl_case3 n1 t1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => addl_case4 n1 t1 n2 + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => addl_case5 n1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), t2 => addl_case6 n1 t1 t2 + | t1, Eop (Oaddlimm n2) (t2:::Enil) => addl_case7 t1 n2 t2 + | e1, e2 => addl_default e1 e2 + end. + +Definition addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else match addl_match e1 e2 with + | addl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + addlimm n1 t2 + | addl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm n2 t1 + | addl_case3 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | addl_case4 n1 t1 n2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | addl_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) *) + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | addl_case6 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | addl_case7 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | addl_default e1 e2 => + Eop Oaddl (e1:::e2:::Enil) + end. + + +(** ** Integer and pointer subtraction *) + +(** Original definition: +<< +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => + addlimm (Int64.neg n2) t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. +>> +*) + +Inductive subl_cases: forall (e1: expr) (e2: expr), Type := + | subl_case1: forall t1 n2, subl_cases (t1) (Eop (Olongconst n2) Enil) + | subl_case2: forall n1 t1 n2 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) + | subl_case3: forall n1 t1 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) + | subl_case4: forall t1 n2 t2, subl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) + | subl_default: forall (e1: expr) (e2: expr), subl_cases e1 e2. + +Definition subl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return subl_cases zz1 zz2 with + | t1, Eop (Olongconst n2) Enil => subl_case1 t1 n2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => subl_case2 n1 t1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), t2 => subl_case3 n1 t1 t2 + | t1, Eop (Oaddlimm n2) (t2:::Enil) => subl_case4 t1 n2 t2 + | e1, e2 => subl_default e1 e2 + end. + +Definition subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else match subl_match e1 e2 with + | subl_case1 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm (Int64.neg n2) t1 + | subl_case2 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | subl_case3 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | subl_case4 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | subl_default e1 e2 => + Eop Osubl (e1:::e2:::Enil) + end. + + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +(** ** Immediate shifts *) + +(** Original definition: +<< +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shl' n1 n) + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + Eop (Oshllimm n) (e1:::Enil) + end. +>> +*) + +Inductive shllimm_cases: forall (e1: expr) , Type := + | shllimm_case1: forall n1, shllimm_cases (Eop (Olongconst n1) Enil) + | shllimm_case2: forall n1 t1, shllimm_cases (Eop (Oshllimm n1) (t1:::Enil)) + | shllimm_default: forall (e1: expr) , shllimm_cases e1. + +Definition shllimm_match (e1: expr) := + match e1 as zz1 return shllimm_cases zz1 with + | Eop (Olongconst n1) Enil => shllimm_case1 n1 + | Eop (Oshllimm n1) (t1:::Enil) => shllimm_case2 n1 t1 + | e1 => shllimm_default e1 + end. + +Definition shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shllimm_match e1 with + | shllimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shl' n1 n) + | shllimm_case2 n1 t1 => (* Eop (Oshllimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) else Eop (Oshllimm n) (e1:::Enil) + | shllimm_default e1 => + Eop (Oshllimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shru' n1 n) + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrluimm_cases: forall (e1: expr) , Type := + | shrluimm_case1: forall n1, shrluimm_cases (Eop (Olongconst n1) Enil) + | shrluimm_case2: forall n1 t1, shrluimm_cases (Eop (Oshrluimm n1) (t1:::Enil)) + | shrluimm_default: forall (e1: expr) , shrluimm_cases e1. + +Definition shrluimm_match (e1: expr) := + match e1 as zz1 return shrluimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrluimm_case1 n1 + | Eop (Oshrluimm n1) (t1:::Enil) => shrluimm_case2 n1 t1 + | e1 => shrluimm_default e1 + end. + +Definition shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) else match shrluimm_match e1 with + | shrluimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shru' n1 n) + | shrluimm_case2 n1 t1 => (* Eop (Oshrluimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil) + | shrluimm_default e1 => + Eop (Oshrluimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shr' n1 n) + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrlimm_cases: forall (e1: expr) , Type := + | shrlimm_case1: forall n1, shrlimm_cases (Eop (Olongconst n1) Enil) + | shrlimm_case2: forall n1 t1, shrlimm_cases (Eop (Oshrlimm n1) (t1:::Enil)) + | shrlimm_default: forall (e1: expr) , shrlimm_cases e1. + +Definition shrlimm_match (e1: expr) := + match e1 as zz1 return shrlimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrlimm_case1 n1 + | Eop (Oshrlimm n1) (t1:::Enil) => shrlimm_case2 n1 t1 + | e1 => shrlimm_default e1 + end. + +Definition shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) else match shrlimm_match e1 with + | shrlimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shr' n1 n) + | shrlimm_case2 n1 t1 => (* Eop (Oshrlimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil) + | shrlimm_default e1 => + Eop (Oshrlimm n) (e1:::Enil) + end. + + +(** ** General shifts *) + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop Omull (e2 ::: longconst n1 ::: Enil) + end. + +(** Original definition: +<< +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. +>> +*) + +Inductive mullimm_cases: forall (e2: expr), Type := + | mullimm_case1: forall n2, mullimm_cases (Eop (Olongconst n2) Enil) + | mullimm_case2: forall n2 t2, mullimm_cases (Eop (Oaddlimm n2) (t2:::Enil)) + | mullimm_default: forall (e2: expr), mullimm_cases e2. + +Definition mullimm_match (e2: expr) := + match e2 as zz1 return mullimm_cases zz1 with + | Eop (Olongconst n2) Enil => mullimm_case1 n2 + | Eop (Oaddlimm n2) (t2:::Enil) => mullimm_case2 n2 t2 + | e2 => mullimm_default e2 + end. + +Definition mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 else if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.one then e2 else match mullimm_match e2 with + | mullimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.mul n1 n2) + | mullimm_case2 n2 t2 => (* Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | mullimm_default e2 => + mullimm_base n1 e2 + end. + + +(** Original definition: +<< +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. +>> +*) + +Inductive mull_cases: forall (e1: expr) (e2: expr), Type := + | mull_case1: forall n1 t2, mull_cases (Eop (Olongconst n1) Enil) (t2) + | mull_case2: forall t1 n2, mull_cases (t1) (Eop (Olongconst n2) Enil) + | mull_default: forall (e1: expr) (e2: expr), mull_cases e1 e2. + +Definition mull_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mull_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => mull_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => mull_case2 t1 n2 + | e1, e2 => mull_default e1 e2 + end. + +Definition mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else match mull_match e1 e2 with + | mull_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + mullimm n1 t2 + | mull_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + mullimm n2 t1 + | mull_default e1 e2 => + Eop Omull (e1:::e2:::Enil) + end. + + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +(** Original definition: +<< +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive andlimm_cases: forall (e2: expr), Type := + | andlimm_case1: forall n2, andlimm_cases (Eop (Olongconst n2) Enil) + | andlimm_case2: forall n2 t2, andlimm_cases (Eop (Oandlimm n2) (t2:::Enil)) + | andlimm_default: forall (e2: expr), andlimm_cases e2. + +Definition andlimm_match (e2: expr) := + match e2 as zz1 return andlimm_cases zz1 with + | Eop (Olongconst n2) Enil => andlimm_case1 n2 + | Eop (Oandlimm n2) (t2:::Enil) => andlimm_case2 n2 t2 + | e2 => andlimm_default e2 + end. + +Definition andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.mone then e2 else match andlimm_match e2 with + | andlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.and n1 n2) + | andlimm_case2 n2 t2 => (* Eop (Oandlimm n2) (t2:::Enil) *) + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | andlimm_default e2 => + Eop (Oandlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. +>> +*) + +Inductive andl_cases: forall (e1: expr) (e2: expr), Type := + | andl_case1: forall n1 t2, andl_cases (Eop (Olongconst n1) Enil) (t2) + | andl_case2: forall t1 n2, andl_cases (t1) (Eop (Olongconst n2) Enil) + | andl_default: forall (e1: expr) (e2: expr), andl_cases e1 e2. + +Definition andl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return andl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => andl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => andl_case2 t1 n2 + | e1, e2 => andl_default e1 e2 + end. + +Definition andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else match andl_match e1 e2 with + | andl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + andlimm n1 t2 + | andl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + andlimm n2 t1 + | andl_default e1 e2 => + Eop Oandl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive orlimm_cases: forall (e2: expr), Type := + | orlimm_case1: forall n2, orlimm_cases (Eop (Olongconst n2) Enil) + | orlimm_case2: forall n2 t2, orlimm_cases (Eop (Oorlimm n2) (t2:::Enil)) + | orlimm_default: forall (e2: expr), orlimm_cases e2. + +Definition orlimm_match (e2: expr) := + match e2 as zz1 return orlimm_cases zz1 with + | Eop (Olongconst n2) Enil => orlimm_case1 n2 + | Eop (Oorlimm n2) (t2:::Enil) => orlimm_case2 n2 t2 + | e2 => orlimm_default e2 + end. + +Definition orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else if Int64.eq n1 Int64.mone then longconst Int64.mone else match orlimm_match e2 with + | orlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.or n1 n2) + | orlimm_case2 n2 t2 => (* Eop (Oorlimm n2) (t2:::Enil) *) + Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | orlimm_default e2 => + Eop (Oorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. +>> +*) + +Inductive orl_cases: forall (e1: expr) (e2: expr), Type := + | orl_case1: forall n1 t2, orl_cases (Eop (Olongconst n1) Enil) (t2) + | orl_case2: forall t1 n2, orl_cases (t1) (Eop (Olongconst n2) Enil) + | orl_default: forall (e1: expr) (e2: expr), orl_cases e1 e2. + +Definition orl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return orl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => orl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => orl_case2 t1 n2 + | e1, e2 => orl_default e1 e2 + end. + +Definition orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else match orl_match e1 e2 with + | orl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + orlimm n1 t2 + | orl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + orlimm n2 t1 + | orl_default e1 e2 => + Eop Oorl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => + let n := Int64.xor n1 n2 in + if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive xorlimm_cases: forall (e2: expr), Type := + | xorlimm_case1: forall n2, xorlimm_cases (Eop (Olongconst n2) Enil) + | xorlimm_case2: forall n2 t2, xorlimm_cases (Eop (Oxorlimm n2) (t2:::Enil)) + | xorlimm_default: forall (e2: expr), xorlimm_cases e2. + +Definition xorlimm_match (e2: expr) := + match e2 as zz1 return xorlimm_cases zz1 with + | Eop (Olongconst n2) Enil => xorlimm_case1 n2 + | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_case2 n2 t2 + | e2 => xorlimm_default e2 + end. + +Definition xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else match xorlimm_match e2 with + | xorlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.xor n1 n2) + | xorlimm_case2 n2 t2 => (* Eop (Oxorlimm n2) (t2:::Enil) *) + let n := Int64.xor n1 n2 in if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | xorlimm_default e2 => + Eop (Oxorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. +>> +*) + +Inductive xorl_cases: forall (e1: expr) (e2: expr), Type := + | xorl_case1: forall n1 t2, xorl_cases (Eop (Olongconst n1) Enil) (t2) + | xorl_case2: forall t1 n2, xorl_cases (t1) (Eop (Olongconst n2) Enil) + | xorl_default: forall (e1: expr) (e2: expr), xorl_cases e1 e2. + +Definition xorl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xorl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => xorl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => xorl_case2 t1 n2 + | e1, e2 => xorl_default e1 e2 + end. + +Definition xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else match xorl_match e1 e2 with + | xorl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + xorlimm n1 t2 + | xorl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + xorlimm n2 t1 + | xorl_default e1 e2 => + Eop Oxorl (e1:::e2:::Enil) + end. + + +(** ** Integer logical negation *) + +Definition notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. + +(** ** Integer division and modulus *) + +Definition divlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil). +Definition modlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil). +Definition divls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil). +Definition modls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +(** ** Comparisons *) + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + if Archi.splitlong then SplitLong.longuoffloat e else + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + if Archi.splitlong then SplitLong.floatoflongu e else + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := + if Archi.splitlong then SplitLong.longofsingle e else + Eop Olongofsingle (e:::Enil). + +Definition longuofsingle (e: expr) := + if Archi.splitlong then SplitLong.longuofsingle e else + Eop Olonguofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + if Archi.splitlong then SplitLong.singleoflong e else + Eop Osingleoflong (e:::Enil). + +Definition singleoflongu (e: expr) := + if Archi.splitlong then SplitLong.singleoflongu e else + Eop Osingleoflongu (e:::Enil). + +End SELECT. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp new file mode 100644 index 00000000..b3e07bf5 --- /dev/null +++ b/mppa_k1c/SelectLong.vp @@ -0,0 +1,364 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +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 => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) 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 (Oaddlimm n) (e ::: Enil) + end. + +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => + addlimm (Int64.neg n2) t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shl' n1 n) + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + Eop (Oshllimm n) (e1:::Enil) + end. + +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shru' n1 n) + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. + +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shr' n1 n) + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. + +(** ** General shifts *) + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop Omull (e2 ::: longconst n1 ::: Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. + +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. + +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. + +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. + +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. + +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => + let n := Int64.xor n1 n2 in + if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. + +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Definition notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. + +(** ** Integer division and modulus *) + +Definition divlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil). +Definition modlu_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil). +Definition divls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil). +Definition modls_base (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +(** ** Comparisons *) + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + if Archi.splitlong then SplitLong.longuoffloat e else + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + if Archi.splitlong then SplitLong.floatoflongu e else + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := + if Archi.splitlong then SplitLong.longofsingle e else + Eop Olongofsingle (e:::Enil). + +Definition longuofsingle (e: expr) := + if Archi.splitlong then SplitLong.longuofsingle e else + Eop Olonguofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + if Archi.splitlong then SplitLong.singleoflong e else + Eop Osingleoflong (e:::Enil). + +Definition singleoflongu (e: expr) := + if Archi.splitlong then SplitLong.singleoflongu e else + Eop Osingleoflongu (e:::Enil). + +End SELECT. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v new file mode 100644 index 00000000..78a1935d --- /dev/null +++ b/mppa_k1c/SelectLongproof.v @@ -0,0 +1,619 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +(** * Correctness of the instruction selection functions for 64-bit operators *) + +Section CMCONSTR. + +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. +Variable sp: val. +Variable e: env. +Variable m: mem. + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := + forall le a x y, + eval_expr ge sp e m le a x -> + sem x = Some y -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. + +Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + sem x y = Some z -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. + +Theorem eval_longconst: + forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). +Proof. + unfold longconst; intros; destruct Archi.splitlong. + apply SplitLongproof.eval_longconst. + EvalOp. +Qed. + +Lemma is_longconst_sound: + forall v a n le, + is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. +Proof with (try discriminate). + intros. unfold is_longconst in *. destruct Archi.splitlong. + eapply SplitLongproof.is_longconst_sound; eauto. + assert (a = Eop (Olongconst n) Enil). + { destruct a... destruct o... destruct e0... congruence. } + subst a. InvEval. auto. +Qed. + +Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. +Proof. + unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. +- TrivialExists. +Qed. + +Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. +Proof. + unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. +Proof. + unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_negl: unary_constructor_sound negl Val.negl. +Proof. + unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- exploit is_longconst_sound; eauto. intros EQ; subst x. + econstructor; split. apply eval_longconst. auto. +- TrivialExists. +Qed. + +Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). +Proof. + unfold addlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst. exists x; split; auto. + destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. + destruct Archi.ptr64; auto. + destruct (addlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. +- 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. +- econstructor; split. EvalOp. simpl; eauto. + 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. +Qed. + +Theorem eval_addl: binary_constructor_sound addl Val.addl. +Proof. + unfold addl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. +(* + assert (SF: Archi.ptr64 = true). + { Local Transparent Archi.splitlong. unfold Archi.splitlong in SL. + destruct Archi.ptr64; simpl in *; congruence. } +*) +(* + assert (B: forall id ofs n, + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))). + { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs. + apply Genv.shift_symbol_address_64; auto. } + +*) + red; intros until y. + case (addl_match a b); intros; InvEval. + - rewrite Val.addl_commut. apply eval_addlimm; auto. + - apply eval_addlimm; auto. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) (Val.addl v0 (Vlong n2))) + with (Val.addl (Val.addl v1 v0) (Val.addl (Vlong n1) (Vlong n2))). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.addl_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. + rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. + destruct Archi.ptr64 eqn:SF; auto. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. + destruct Archi.ptr64 eqn:SF; auto. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) y) + with (Val.addl (Val.addl v1 y) (Vlong n1)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_commut. + - subst. + replace (Val.addl x (Val.addl v1 (Vlong n2))) + with (Val.addl (Val.addl x v1) (Vlong n2)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. reflexivity. + - TrivialExists. +Qed. + +Theorem eval_subl: binary_constructor_sound subl Val.subl. +Proof. + unfold subl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. + red; intros; destruct (subl_match a b); InvEval. +- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. +- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. + rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp. + apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_r. + apply eval_addlimm; EvalOp. +- TrivialExists. +Qed. + +Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). +Proof. + intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. + destruct (shllimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). +Proof. + intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. + destruct (shrluimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). +Proof. + intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. + destruct (shrlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Proof. + unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Proof. + unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Proof. + unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). +Proof. + intros; unfold mullimm_base. red; intros. + assert (DEFAULT: exists v, + eval_expr ge sp e m le (Eop Omull (a ::: longconst n ::: Enil)) v + /\ Val.lessdef (Val.mull x (Vlong n)) v). + { econstructor; split. EvalOp. constructor. eauto. constructor. apply eval_longconst. constructor. simpl; eauto. + auto. } + generalize (Int64.one_bits'_decomp n); intros D. + destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. +- apply DEFAULT. +- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). + apply eval_shllimm; auto. + simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. + rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib). + rewrite Int64.shl'_mul; auto. +- set (le' := x :: le). + assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity). + exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1). + exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2). + exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3). + exists v3; split. econstructor; eauto. + rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto. + simpl in *. + rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib). + rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). + inv B1; inv B2. simpl in B3; inv B3. + rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. +- apply DEFAULT. +Qed. + +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). +Proof. + unfold mullimm. intros; red; intros. + destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_mullimm; eauto. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one. + exists x; split; auto. + destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto. + destruct (mullimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto. +- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2). + exploit (eval_addlimm (Int64.mul n n2)). eexact A2. intros (v3 & A3 & B3). + exists v3; split; auto. + subst x. destruct v1; simpl; auto. + simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. + rewrite (Int64.mul_commut n). auto. + destruct Archi.ptr64; simpl; auto. +- apply eval_mullimm_base; auto. +Qed. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Proof. + unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto. + red; intros; destruct (mull_match a b); InvEval. +- rewrite Val.mull_commut. apply eval_mullimm; auto. +- apply eval_mullimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullhu: + forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). +Proof. + unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). +Proof. + unfold andlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + exists x; split. assumption. + subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. + destruct (andlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. +- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_andl: binary_constructor_sound andl Val.andl. +Proof. + unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. + red; intros. destruct (andl_match a b). +- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. +- InvEval. apply eval_andlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). +Proof. + unfold orlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. + destruct (orlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. +- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Proof. + unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. + red; intros. + destruct (orl_match a b). +- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. +- InvEval. apply eval_orlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). +Proof. + unfold xorlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. + destruct (xorlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. +- rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). + predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. ++ rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. ++ TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Proof. + unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. + red; intros. destruct (xorl_match a b). +- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. +- InvEval. apply eval_xorlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_notl: unary_constructor_sound notl Val.notl. +Proof. + unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl. + red; intros. rewrite Val.notl_xorl. apply eval_xorlimm; auto. +Qed. + +Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. +Proof. + unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_divls_base; eauto. + TrivialExists. +Qed. + +Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. +Proof. + unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_modls_base; eauto. + TrivialExists. +Qed. + +Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. +Proof. + unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_divlu_base; eauto. + TrivialExists. +Qed. + +Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. +Proof. + unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_modlu_base; eauto. + TrivialExists. +Qed. + +Theorem eval_shrxlimm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrxl x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. +Proof. + unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. + change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. +- TrivialExists. +(* + intros. unfold shrxlimm. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ destruct x; simpl in H0; try discriminate. + destruct (Int.ltu n (Int.repr 63)) eqn:LTU; inv H0. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. exists (Vlong i); split; auto. rewrite Int64.shrx'_zero. auto. + - assert (NZ: Int.unsigned n <> 0). + { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } + assert (LT: 0 <= Int.unsigned n < 63) by (apply Int.ltu_inv in LTU; assumption). + assert (LTU2: Int.ltu (Int.sub Int64.iwordsize' n) Int64.iwordsize' = true). + { unfold Int.ltu; apply zlt_true. + unfold Int.sub. change (Int.unsigned Int64.iwordsize') with 64. + rewrite Int.unsigned_repr. omega. + assert (64 < Int.max_unsigned) by reflexivity. omega. } + assert (X: eval_expr ge sp e m le + (Eop (Oshrlimm (Int.repr (Int64.zwordsize - 1))) (a ::: Enil)) + (Vlong (Int64.shr' i (Int.repr (Int64.zwordsize - 1))))). + { EvalOp. } + assert (Y: eval_expr ge sp e m le (shrxlimm_inner a n) + (Vlong (Int64.shru' (Int64.shr' i (Int.repr (Int64.zwordsize - 1))) (Int.sub Int64.iwordsize' n)))). + { EvalOp. simpl. rewrite LTU2. auto. } + TrivialExists. + constructor. EvalOp. simpl; eauto. constructor. + simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int64.shrx'_shr_2 by auto. reflexivity. + change (Int.unsigned Int64.iwordsize') with 64; omega. +*) +Qed. + +Theorem eval_cmplu: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmplu (Mem.valid_pointer m) c x y = Some v -> + eval_expr ge sp e m le (cmplu c a b) v. +Proof. + unfold cmplu; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32. + unfold Val.cmplu in H1. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_cmpl: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmpl c x y = Some v -> + eval_expr ge sp e m le (cmpl c a b) v. +Proof. + unfold cmpl; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmpl; eauto. + unfold Val.cmpl in H1. + destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. +Proof. + unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longoffloat; eauto. + TrivialExists. +Qed. + +Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. +Proof. + unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longuoffloat; eauto. + TrivialExists. +Qed. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Proof. + unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflong; eauto. + TrivialExists. +Qed. + +Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. +Proof. + unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflongu; eauto. + TrivialExists. +Qed. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Proof. + unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longofsingle; eauto. + TrivialExists. +Qed. + +Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. +Proof. + unfold longuofsingle; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longuofsingle; eauto. + TrivialExists. +Qed. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Proof. + unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_singleoflong; eauto. + TrivialExists. +Qed. + +Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. +Proof. + unfold singleoflongu; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_singleoflongu; eauto. + TrivialExists. +Qed. + +End CMCONSTR. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v new file mode 100644 index 00000000..c42f0340 --- /dev/null +++ b/mppa_k1c/SelectOp.v @@ -0,0 +1,1219 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Archi. +Require Import Coqlib. +Require Import Compopts. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Op. +Require Import CminorSel. + +Local Open Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition and pointer addition *) + +(** Original definition: +<< +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (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 (Oaddimm n) (e ::: Enil) + end. +>> +*) + +Inductive addimm_cases: forall (e: expr), Type := + | addimm_case1: forall m, addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: forall s m, addimm_cases (Eop (Oaddrsymbol s m) Enil) + | addimm_case3: forall m, addimm_cases (Eop (Oaddrstack m) Enil) + | addimm_case4: forall m t, addimm_cases (Eop (Oaddimm m) (t ::: Enil)) + | addimm_default: forall (e: expr), addimm_cases e. + +Definition addimm_match (e: expr) := + match e as zz1 return addimm_cases zz1 with + | Eop (Ointconst m) Enil => addimm_case1 m + | Eop (Oaddrsymbol s m) Enil => addimm_case2 s m + | Eop (Oaddrstack m) Enil => addimm_case3 m + | Eop (Oaddimm m) (t ::: Enil) => addimm_case4 m t + | e => addimm_default e + end. + +Definition addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else match addimm_match e with + | addimm_case1 m => (* Eop (Ointconst m) Enil *) + Eop (Ointconst (Int.add n m)) Enil + | addimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) + Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | addimm_case3 m => (* Eop (Oaddrstack m) Enil *) + Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | addimm_case4 m t => (* Eop (Oaddimm m) (t ::: Enil) *) + Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | addimm_default e => + Eop (Oaddimm n) (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. +>> +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Type := + | add_case1: forall n1 t2, add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: forall t1 n2, add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case3: forall n1 t1 n2 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case4: forall n1 t1 n2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) + | add_case5: forall n1 n2 t2, add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case6: forall n1 t1 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | add_case7: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. + +Definition add_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return add_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => add_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => add_case2 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => add_case3 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => add_case4 n1 t1 n2 + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => add_case5 n1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => add_case6 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case7 t1 n2 t2 + | e1, e2 => add_default e1 e2 + end. + +Definition add (e1: expr) (e2: expr) := + match add_match e1 e2 with + | add_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + addimm n1 t2 + | add_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm n2 t1 + | add_case3 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | add_case4 n1 t1 n2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | add_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) *) + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | add_case6 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | add_case7 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | add_default e1 e2 => + Eop Oadd (e1:::e2:::Enil) + end. + + +(** ** Integer and pointer subtraction *) + +(** Original definition: +<< +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. +>> +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Type := + | sub_case1: forall t1 n2, sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: forall n1 t1 n2 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case3: forall n1 t1 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | sub_case4: forall t1 n2 t2, sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_default: forall (e1: expr) (e2: expr), sub_cases e1 e2. + +Definition sub_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return sub_cases zz1 zz2 with + | t1, Eop (Ointconst n2) Enil => sub_case1 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => sub_case2 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => sub_case3 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => sub_case4 t1 n2 t2 + | e1, e2 => sub_default e1 e2 + end. + +Definition sub (e1: expr) (e2: expr) := + match sub_match e1 e2 with + | sub_case1 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm (Int.neg n2) t1 + | sub_case2 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | sub_case3 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | sub_case4 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | sub_default e1 e2 => + Eop Osub (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. +>> +*) + +Inductive negint_cases: forall (e: expr), Type := + | negint_case1: forall n, negint_cases (Eop (Ointconst n) Enil) + | negint_default: forall (e: expr), negint_cases e. + +Definition negint_match (e: expr) := + match e as zz1 return negint_cases zz1 with + | Eop (Ointconst n) Enil => negint_case1 n + | e => negint_default e + end. + +Definition negint (e: expr) := + match negint_match e with + | negint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.neg n)) Enil + | negint_default e => + Eop Oneg (e ::: Enil) + end. + + +(** ** Immediate shifts *) + +(** Original definition: +<< +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + Eop (Oshlimm n) (e1:::Enil) + end. +>> +*) + +Inductive shlimm_cases: forall (e1: expr) , Type := + | shlimm_case1: forall n1, shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: forall n1 t1, shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) + | shlimm_default: forall (e1: expr) , shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as zz1 return shlimm_cases zz1 with + | Eop (Ointconst n1) Enil => shlimm_case1 n1 + | Eop (Oshlimm n1) (t1:::Enil) => shlimm_case2 n1 t1 + | e1 => shlimm_default e1 + end. + +Definition shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shlimm_match e1 with + | shlimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => (* Eop (Oshlimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) + | shlimm_default e1 => + Eop (Oshlimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. +>> +*) + +Inductive shruimm_cases: forall (e1: expr) , Type := + | shruimm_case1: forall n1, shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: forall n1 t1, shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) + | shruimm_default: forall (e1: expr) , shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as zz1 return shruimm_cases zz1 with + | Eop (Ointconst n1) Enil => shruimm_case1 n1 + | Eop (Oshruimm n1) (t1:::Enil) => shruimm_case2 n1 t1 + | e1 => shruimm_default e1 + end. + +Definition shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shruimm_match e1 with + | shruimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => (* Eop (Oshruimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) + | shruimm_default e1 => + Eop (Oshruimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrimm_cases: forall (e1: expr) , Type := + | shrimm_case1: forall n1, shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: forall n1 t1, shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) + | shrimm_default: forall (e1: expr) , shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as zz1 return shrimm_cases zz1 with + | Eop (Ointconst n1) Enil => shrimm_case1 n1 + | Eop (Oshrimm n1) (t1:::Enil) => shrimm_case2 n1 t1 + | e1 => shrimm_default e1 + end. + +Definition shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shrimm_match e1 with + | shrimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => (* Eop (Oshrimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) + | shrimm_default e1 => + Eop (Oshrimm n) (e1:::Enil) + end. + + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +(** Original definition: +<< +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. +>> +*) + +Inductive mulimm_cases: forall (e2: expr), Type := + | mulimm_case1: forall n2, mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: forall n2 t2, mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) + | mulimm_default: forall (e2: expr), mulimm_cases e2. + +Definition mulimm_match (e2: expr) := + match e2 as zz1 return mulimm_cases zz1 with + | Eop (Ointconst n2) Enil => mulimm_case1 n2 + | Eop (Oaddimm n2) (t2:::Enil) => mulimm_case2 n2 t2 + | e2 => mulimm_default e2 + end. + +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.one then e2 else match mulimm_match e2 with + | mulimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.mul n1 n2)) Enil + | mulimm_case2 n2 t2 => (* Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | mulimm_default e2 => + mulimm_base n1 e2 + end. + + +(** Original definition: +<< +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. +>> +*) + +Inductive mul_cases: forall (e1: expr) (e2: expr), Type := + | mul_case1: forall n1 t2, mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: forall t1 n2, mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: forall (e1: expr) (e2: expr), mul_cases e1 e2. + +Definition mul_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mul_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => mul_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => mul_case2 t1 n2 + | e1, e2 => mul_default e1 e2 + end. + +Definition mul (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + mulimm n1 t2 + | mul_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + mulimm n2 t1 + | mul_default e1 e2 => + Eop Omul (e1:::e2:::Enil) + end. + + +Definition mulhs (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrlimm (Int.repr 32)) + (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: + Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhs (e1 ::: e2 ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrluimm (Int.repr 32)) + (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: + Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +(** Original definition: +<< +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | _ => Eop (Oandimm n1) (e2:::Enil) + end. +>> +*) + +Inductive andimm_cases: forall (e2: expr), Type := + | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) + | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) + | andimm_default: forall (e2: expr), andimm_cases e2. + +Definition andimm_match (e2: expr) := + match e2 as zz1 return andimm_cases zz1 with + | Eop (Ointconst n2) Enil => andimm_case1 n2 + | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 + | e2 => andimm_default e2 + end. + +Definition andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.mone then e2 else match andimm_match e2 with + | andimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.and n1 n2)) Enil + | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | andimm_default e2 => + Eop (Oandimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. +>> +*) + +Inductive and_cases: forall (e1: expr) (e2: expr), Type := + | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) + | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) + | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. + +Definition and_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 + | e1, e2 => and_default e1 e2 + end. + +Definition and (e1: expr) (e2: expr) := + match and_match e1 e2 with + | and_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + andimm n1 t2 + | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + andimm n2 t1 + | and_default e1 e2 => + Eop Oand (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive orimm_cases: forall (e2: expr), Type := + | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) + | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) + | orimm_default: forall (e2: expr), orimm_cases e2. + +Definition orimm_match (e2: expr) := + match e2 as zz1 return orimm_cases zz1 with + | Eop (Ointconst n2) Enil => orimm_case1 n2 + | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 + | e2 => orimm_default e2 + end. + +Definition orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil else match orimm_match e2 with + | orimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.or n1 n2)) Enil + | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | orimm_default e2 => + Eop (Oorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | _, _ => Eop Oor (e1:::e2:::Enil) + end. +>> +*) + +Inductive or_cases: forall (e1: expr) (e2: expr), Type := + | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) + | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) + | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. + +Definition or_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 + | e1, e2 => or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + orimm n1 t2 + | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + orimm n2 t1 + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + let n := Int.xor n1 n2 in + if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive xorimm_cases: forall (e2: expr), Type := + | xorimm_case1: forall n2, xorimm_cases (Eop (Ointconst n2) Enil) + | xorimm_case2: forall n2 t2, xorimm_cases (Eop (Oxorimm n2) (t2:::Enil)) + | xorimm_default: forall (e2: expr), xorimm_cases e2. + +Definition xorimm_match (e2: expr) := + match e2 as zz1 return xorimm_cases zz1 with + | Eop (Ointconst n2) Enil => xorimm_case1 n2 + | Eop (Oxorimm n2) (t2:::Enil) => xorimm_case2 n2 t2 + | e2 => xorimm_default e2 + end. + +Definition xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else match xorimm_match e2 with + | xorimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.xor n1 n2)) Enil + | xorimm_case2 n2 t2 => (* Eop (Oxorimm n2) (t2:::Enil) *) + let n := Int.xor n1 n2 in if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | xorimm_default e2 => + Eop (Oxorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. +>> +*) + +Inductive xor_cases: forall (e1: expr) (e2: expr), Type := + | xor_case1: forall n1 t2, xor_cases (Eop (Ointconst n1) Enil) (t2) + | xor_case2: forall t1 n2, xor_cases (t1) (Eop (Ointconst n2) Enil) + | xor_default: forall (e1: expr) (e2: expr), xor_cases e1 e2. + +Definition xor_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xor_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => xor_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => xor_case2 t1 n2 + | e1, e2 => xor_default e1 e2 + end. + +Definition xor (e1: expr) (e2: expr) := + match xor_match e1 e2 with + | xor_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + xorimm n1 t2 + | xor_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + xorimm n2 t1 + | xor_default e1 e2 => + Eop Oxor (e1:::e2:::Enil) + end. + + +(** ** Integer logical negation *) + +Definition notint (e: expr) := xorimm Int.mone e. + +(** ** Integer division and modulus *) + +Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). +Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). + +(* Alternate definition, not convenient for strength reduction during constant propagation *) +(* +(* n2 will be less than 31. *) + +Definition shrximm_inner (e1: expr) (n2: int) := + Eop (Oshruimm (Int.sub Int.iwordsize n2)) + ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) + (e1 ::: Enil)) + ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 + else Eop (Oshrimm n2) + ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) + ::: Enil). +*) + +(** ** General shifts *) + +(** Original definition: +<< +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. +>> +*) + +Inductive shl_cases: forall (e2: expr), Type := + | shl_case1: forall n2, shl_cases (Eop (Ointconst n2) Enil) + | shl_default: forall (e2: expr), shl_cases e2. + +Definition shl_match (e2: expr) := + match e2 as zz1 return shl_cases zz1 with + | Eop (Ointconst n2) Enil => shl_case1 n2 + | e2 => shl_default e2 + end. + +Definition shl (e1: expr) (e2: expr) := + match shl_match e2 with + | shl_case1 n2 => (* Eop (Ointconst n2) Enil *) + shlimm e1 n2 + | shl_default e2 => + Eop Oshl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. +>> +*) + +Inductive shr_cases: forall (e2: expr), Type := + | shr_case1: forall n2, shr_cases (Eop (Ointconst n2) Enil) + | shr_default: forall (e2: expr), shr_cases e2. + +Definition shr_match (e2: expr) := + match e2 as zz1 return shr_cases zz1 with + | Eop (Ointconst n2) Enil => shr_case1 n2 + | e2 => shr_default e2 + end. + +Definition shr (e1: expr) (e2: expr) := + match shr_match e2 with + | shr_case1 n2 => (* Eop (Ointconst n2) Enil *) + shrimm e1 n2 + | shr_default e2 => + Eop Oshr (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. +>> +*) + +Inductive shru_cases: forall (e2: expr), Type := + | shru_case1: forall n2, shru_cases (Eop (Ointconst n2) Enil) + | shru_default: forall (e2: expr), shru_cases e2. + +Definition shru_match (e2: expr) := + match e2 as zz1 return shru_cases zz1 with + | Eop (Ointconst n2) Enil => shru_case1 n2 + | e2 => shru_default e2 + end. + +Definition shru (e1: expr) (e2: expr) := + match shru_match e2 with + | shru_case1 n2 => (* Eop (Ointconst n2) Enil *) + shruimm e1 n2 + | shru_default e2 => + Eop Oshru (e1:::e2:::Enil) + end. + + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). + +Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). +Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). +Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). +Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). +Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +(** Original definition: +<< +Nondetfunction compimm (default: comparison -> int -> condition) + (sem: comparison -> int -> int -> bool) + (c: comparison) (e1: expr) (n2: int) := + match c, e1 with + | c, Eop (Ointconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp (negate_condition c)) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp c) el + else + Eop (Ointconst Int.zero) Enil + | Cne, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp c) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp (negate_condition c)) el + else + Eop (Ointconst Int.one) Enil + | _, _ => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. +>> +*) + +Inductive compimm_cases: forall (c: comparison) (e1: expr) , Type := + | compimm_case1: forall c n1, compimm_cases (c) (Eop (Ointconst n1) Enil) + | compimm_case2: forall c el, compimm_cases (Ceq) (Eop (Ocmp c) el) + | compimm_case3: forall c el, compimm_cases (Cne) (Eop (Ocmp c) el) + | compimm_default: forall (c: comparison) (e1: expr) , compimm_cases c e1. + +Definition compimm_match (c: comparison) (e1: expr) := + match c as zz1, e1 as zz2 return compimm_cases zz1 zz2 with + | c, Eop (Ointconst n1) Enil => compimm_case1 c n1 + | Ceq, Eop (Ocmp c) el => compimm_case2 c el + | Cne, Eop (Ocmp c) el => compimm_case3 c el + | c, e1 => compimm_default c e1 + end. + +Definition compimm (default: comparison -> int -> condition) (sem: comparison -> int -> int -> bool) (c: comparison) (e1: expr) (n2: int) := + match compimm_match c e1 with + | compimm_case1 c n1 => (* c, Eop (Ointconst n1) Enil *) + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | compimm_case2 c el => (* Ceq, Eop (Ocmp c) el *) + if Int.eq_dec n2 Int.zero then Eop (Ocmp (negate_condition c)) el else if Int.eq_dec n2 Int.one then Eop (Ocmp c) el else Eop (Ointconst Int.zero) Enil + | compimm_case3 c el => (* Cne, Eop (Ocmp c) el *) + if Int.eq_dec n2 Int.zero then Eop (Ocmp c) el else if Int.eq_dec n2 Int.one then Eop (Ocmp (negate_condition c)) el else Eop (Ointconst Int.one) Enil + | compimm_default c e1 => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompimm Int.cmp c t1 n2 + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. +>> +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Type := + | comp_case1: forall n1 t2, comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: forall t1 n2, comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_default: forall (e1: expr) (e2: expr), comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return comp_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => comp_case2 t1 n2 + | e1, e2 => comp_default e1 e2 + end. + +Definition comp (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | comp_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompimm Int.cmp c t1 n2 + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompuimm Int.cmpu c t1 n2 + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. +>> +*) + +Inductive compu_cases: forall (e1: expr) (e2: expr), Type := + | compu_case1: forall n1 t2, compu_cases (Eop (Ointconst n1) Enil) (t2) + | compu_case2: forall t1 n2, compu_cases (t1) (Eop (Ointconst n2) Enil) + | compu_default: forall (e1: expr) (e2: expr), compu_cases e1 e2. + +Definition compu_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return compu_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => compu_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => compu_case2 t1 n2 + | e1, e2 => compu_default e1 e2 + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match compu_match e1 e2 with + | compu_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | compu_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompuimm Int.cmpu c t1 n2 + | compu_default e1 e2 => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +(** Original definition: +<< +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => Eop Ocast8signed (e ::: Enil) + end. +>> +*) + +Inductive cast8signed_cases: forall (e: expr), Type := + | cast8signed_case1: forall n, cast8signed_cases (Eop (Ointconst n) Enil) + | cast8signed_default: forall (e: expr), cast8signed_cases e. + +Definition cast8signed_match (e: expr) := + match e as zz1 return cast8signed_cases zz1 with + | Eop (Ointconst n) Enil => cast8signed_case1 n + | e => cast8signed_default e + end. + +Definition cast8signed (e: expr) := + match cast8signed_match e with + | cast8signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 8 n)) Enil + | cast8signed_default e => + Eop Ocast8signed (e ::: Enil) + end. + + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +(** Original definition: +<< +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => Eop Ocast16signed (e ::: Enil) + end. +>> +*) + +Inductive cast16signed_cases: forall (e: expr), Type := + | cast16signed_case1: forall n, cast16signed_cases (Eop (Ointconst n) Enil) + | cast16signed_default: forall (e: expr), cast16signed_cases e. + +Definition cast16signed_match (e: expr) := + match e as zz1 return cast16signed_cases zz1 with + | Eop (Ointconst n) Enil => cast16signed_case1 n + | e => cast16signed_default e + end. + +Definition cast16signed (e: expr) := + match cast16signed_match e with + | cast16signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 16 n)) Enil + | cast16signed_default e => + Eop Ocast16signed (e ::: Enil) + end. + + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +(** Original definition: +<< +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatofintu (e ::: Enil) + end. +>> +*) + +Inductive floatofintu_cases: forall (e: expr), Type := + | floatofintu_case1: forall n, floatofintu_cases (Eop (Ointconst n) Enil) + | floatofintu_default: forall (e: expr), floatofintu_cases e. + +Definition floatofintu_match (e: expr) := + match e as zz1 return floatofintu_cases zz1 with + | Eop (Ointconst n) Enil => floatofintu_case1 n + | e => floatofintu_default e + end. + +Definition floatofintu (e: expr) := + match floatofintu_match e with + | floatofintu_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_intu n)) Enil + | floatofintu_default e => + Eop Ofloatofintu (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. +>> +*) + +Inductive floatofint_cases: forall (e: expr), Type := + | floatofint_case1: forall n, floatofint_cases (Eop (Ointconst n) Enil) + | floatofint_default: forall (e: expr), floatofint_cases e. + +Definition floatofint_match (e: expr) := + match e as zz1 return floatofint_cases zz1 with + | Eop (Ointconst n) Enil => floatofint_case1 n + | e => floatofint_default e + end. + +Definition floatofint (e: expr) := + match floatofint_match e with + | floatofint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_int n)) Enil + | floatofint_default e => + Eop Ofloatofint (e ::: Enil) + end. + + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). + +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). +Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +(** Original definition: +<< +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code 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) + | _ => (Aindexed Ptrofs.zero, e:::Enil) + end. +>> +*) + +Inductive addressing_cases: forall (e: expr), Type := + | addressing_case1: forall n, addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case2: forall id ofs, addressing_cases (Eop (Oaddrsymbol id ofs) Enil) + | addressing_case3: forall n e1, addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case4: forall n e1, addressing_cases (Eop (Oaddlimm n) (e1:::Enil)) + | addressing_default: forall (e: expr), addressing_cases e. + +Definition addressing_match (e: expr) := + match e as zz1 return addressing_cases zz1 with + | Eop (Oaddrstack n) Enil => addressing_case1 n + | Eop (Oaddrsymbol id ofs) Enil => addressing_case2 id ofs + | Eop (Oaddimm n) (e1:::Enil) => addressing_case3 n e1 + | Eop (Oaddlimm n) (e1:::Enil) => addressing_case4 n e1 + | e => addressing_default e + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case1 n => (* Eop (Oaddrstack n) Enil *) + (Ainstack n, Enil) + | addressing_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) + if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) + | addressing_case3 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) + (Aindexed (Ptrofs.of_int n), e1:::Enil) + | addressing_case4 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) + (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | addressing_default e => + (Aindexed Ptrofs.zero, e:::Enil) + end. + + +(** ** Arguments of builtins *) + +(** Original definition: +<< +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | Eop (Oaddlimm n) (e1:::Enil) => + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | _ => BA e + end. +>> +*) + +Inductive builtin_arg_cases: forall (e: expr), Type := + | builtin_arg_case1: forall n, builtin_arg_cases (Eop (Ointconst n) Enil) + | builtin_arg_case2: forall id ofs, builtin_arg_cases (Eop (Oaddrsymbol id ofs) Enil) + | builtin_arg_case3: forall ofs, builtin_arg_cases (Eop (Oaddrstack ofs) Enil) + | builtin_arg_case4: forall h l, builtin_arg_cases (Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil)) + | builtin_arg_case5: forall h l, builtin_arg_cases (Eop Omakelong (h ::: l ::: Enil)) + | builtin_arg_case6: forall chunk ofs, builtin_arg_cases (Eload chunk (Ainstack ofs) Enil) + | builtin_arg_case7: forall n e1, builtin_arg_cases (Eop (Oaddimm n) (e1:::Enil)) + | builtin_arg_case8: forall n e1, builtin_arg_cases (Eop (Oaddlimm n) (e1:::Enil)) + | builtin_arg_default: forall (e: expr), builtin_arg_cases e. + +Definition builtin_arg_match (e: expr) := + match e as zz1 return builtin_arg_cases zz1 with + | Eop (Ointconst n) Enil => builtin_arg_case1 n + | Eop (Oaddrsymbol id ofs) Enil => builtin_arg_case2 id ofs + | Eop (Oaddrstack ofs) Enil => builtin_arg_case3 ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => builtin_arg_case4 h l + | Eop Omakelong (h ::: l ::: Enil) => builtin_arg_case5 h l + | Eload chunk (Ainstack ofs) Enil => builtin_arg_case6 chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => builtin_arg_case7 n e1 + | Eop (Oaddlimm n) (e1:::Enil) => builtin_arg_case8 n e1 + | e => builtin_arg_default e + end. + +Definition builtin_arg (e: expr) := + match builtin_arg_match e with + | builtin_arg_case1 n => (* Eop (Ointconst n) Enil *) + BA_int n + | builtin_arg_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) + BA_addrglobal id ofs + | builtin_arg_case3 ofs => (* Eop (Oaddrstack ofs) Enil *) + BA_addrstack ofs + | builtin_arg_case4 h l => (* Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) *) + BA_long (Int64.ofwords h l) + | builtin_arg_case5 h l => (* Eop Omakelong (h ::: l ::: Enil) *) + BA_splitlong (BA h) (BA l) + | builtin_arg_case6 chunk ofs => (* Eload chunk (Ainstack ofs) Enil *) + BA_loadstack chunk ofs + | builtin_arg_case7 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | builtin_arg_case8 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | builtin_arg_default e => + BA e + end. + diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp new file mode 100644 index 00000000..bb8af2ed --- /dev/null +++ b/mppa_k1c/SelectOp.vp @@ -0,0 +1,450 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Archi. +Require Import Coqlib. +Require Import Compopts. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Op. +Require Import CminorSel. + +Local Open Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition and pointer addition *) + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (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 (Oaddimm n) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. + +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + Eop (Oshlimm n) (e1:::Enil) + end. + +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. + +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +Definition mulhs (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrlimm (Int.repr 32)) + (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: + Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhs (e1 ::: e2 ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrluimm (Int.repr 32)) + (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: + Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | _ => Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | _, _ => Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + let n := Int.xor n1 n2 in + if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Definition notint (e: expr) := xorimm Int.mone e. + +(** ** Integer division and modulus *) + +Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). +Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). + +(* Alternate definition, not convenient for strength reduction during constant propagation *) +(* +(* n2 will be less than 31. *) + +Definition shrximm_inner (e1: expr) (n2: int) := + Eop (Oshruimm (Int.sub Int.iwordsize n2)) + ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) + (e1 ::: Enil)) + ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 + else Eop (Oshrimm n2) + ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) + ::: Enil). +*) + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). + +Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). +Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). +Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). +Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). +Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction compimm (default: comparison -> int -> condition) + (sem: comparison -> int -> int -> bool) + (c: comparison) (e1: expr) (n2: int) := + match c, e1 with + | c, Eop (Ointconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp (negate_condition c)) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp c) el + else + Eop (Ointconst Int.zero) Enil + | Cne, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp c) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp (negate_condition c)) el + else + Eop (Ointconst Int.one) Enil + | _, _ => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompimm Int.cmp c t1 n2 + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompuimm Int.cmpu c t1 n2 + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => Eop Ocast8signed (e ::: Enil) + end. + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => Eop Ocast16signed (e ::: Enil) + end. + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatofintu (e ::: Enil) + end. + +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). + +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). +Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code 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) + | _ => (Aindexed Ptrofs.zero, e:::Enil) + end. + +(** ** Arguments of builtins *) + +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | Eop (Oaddlimm n) (e1:::Enil) => + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | _ => BA e + end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v new file mode 100644 index 00000000..90f077db --- /dev/null +++ b/mppa_k1c/SelectOpproof.v @@ -0,0 +1,925 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for operators *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import SelectOp. + +Local Open Scope cminorsel_scope. + +(** * Useful lemmas and tactics *) + +(** The following are trivial lemmas and custom tactics that help + perform backward (inversion) and forward reasoning over the evaluation + of operator applications. *) + +Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + +(** * Correctness of the smart constructors *) + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** We now show that the code generated by "smart constructor" functions + such as [Selection.notint] behaves as expected. Continuing the + [notint] example, we show that if the expression [e] + evaluates to some integer value [Vint n], then [Selection.notint e] + evaluates to a value [Vint (Int.not n)] which is indeed the integer + negation of the value of [e]. + + All proofs follow a common pattern: +- Reasoning by case over the result of the classification functions + (such as [add_match] for integer addition), gathering additional + information on the shape of the argument expressions in the non-default + cases. +- Inversion of the evaluations of the arguments, exploiting the additional + information thus gathered. +- Equational reasoning over the arithmetic operations performed, + using the lemmas from the [Int] and [Float] modules. +- Construction of an evaluation derivation for the expression returned + by the smart constructor. +*) + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Theorem eval_addrsymbol: + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. +Proof. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addrstack: + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. +Proof. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addimm: + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. intros. exists x; split; auto. + destruct x; simpl; auto. + rewrite Int.add_zero; auto. + destruct Archi.ptr64; auto. rewrite Ptrofs.add_zero; auto. + - case (addimm_match a); intros; InvEval; simpl. + + TrivialExists; simpl. rewrite Int.add_commut. auto. + + 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. + + econstructor; split. EvalOp. simpl; eauto. + destruct sp; simpl; auto. destruct Archi.ptr64; auto. + rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut m0). auto. + + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + TrivialExists. +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. + unfold add; case (add_match a b); intros; InvEval. + - rewrite Val.add_commut. apply eval_addimm; auto. + - apply eval_addimm; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) + with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.add_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. + rewrite (Ptrofs.add_commut (Ptrofs.of_int n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. + destruct Archi.ptr64 eqn:SF; auto. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. + destruct Archi.ptr64 eqn:SF; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) y) + with (Val.add (Val.add v1 y) (Vint n1)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. + - subst. + replace (Val.add x (Val.add v1 (Vint n2))) + with (Val.add (Val.add x v1) (Vint n2)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. reflexivity. + - TrivialExists. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + - rewrite Val.sub_add_opp. apply eval_addimm; auto. + - subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + 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. +Qed. + +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Proof. + red; intros until x. unfold negint. case (negint_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_shlimm: + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros until x. unfold shlimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shlimm_match a); intros; InvEval. + - exists (Vint (Int.shl n1 n)); split. EvalOp. + simpl. rewrite LT. auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. + + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shruimm: + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shruimm_match a); intros; InvEval. + - exists (Vint (Int.shru n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shrimm: + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shrimm_match a); intros; InvEval. + - exists (Vint (Int.shr n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Lemma eval_mulimm_base: + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros; unfold mulimm_base. + + assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v). + TrivialExists. econstructor. EvalOp. simpl; eauto. econstructor. eauto. constructor. + rewrite Val.mul_commut. auto. + + generalize (Int.one_bits_decomp n). + generalize (Int.one_bits_range n). + destruct (Int.one_bits n). + - intros. auto. + - destruct l. + + intros. rewrite H1. simpl. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. + + destruct l. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]]. + exists v; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. auto. +Qed. + +Theorem eval_mulimm: + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. + + case (mulimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.mul_commut; auto. + - subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + - apply eval_mulimm_base; auto. +Qed. + +Theorem eval_mul: binary_constructor_sound mul Val.mul. +Proof. + red; intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Val.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + TrivialExists. +Qed. + +Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs. +Proof. + red; intros. unfold mulhs; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + 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. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shr' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. +Proof. + red; intros. unfold mulhu; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + 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. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shru' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). +Proof. + intros; red; intros until x. unfold andimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists x; split; auto. + subst. destruct x; simpl; auto. rewrite Int.and_mone; auto. + + case (andimm_match a); intros. + - InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. + - InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + - rewrite Val.and_commut. apply eval_andimm; auto. + - apply eval_andimm; auto. + - TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. subst. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.or_zero; auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists (Vint Int.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. + + destruct (orimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.or_commut; auto. + - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros; InvEval. + - rewrite Val.or_commut. apply eval_orimm; auto. + - apply eval_orimm; auto. + - TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + + intros. destruct (xorimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.xor_commut; auto. + - subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. + predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. + + exists v1; split; auto. destruct v1; simpl; auto. rewrite H0, Int.xor_zero; auto. + + TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + - rewrite Val.xor_commut. apply eval_xorimm; auto. + - apply eval_xorimm; auto. + - TrivialExists. +Qed. + +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + unfold notint; red; intros. rewrite Val.not_xor. apply eval_xorimm; auto. +Qed. + +Theorem eval_divs_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divs_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_mods_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold mods_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_divu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divu_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_modu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold modu_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_shrximm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrx x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v. +Proof. + intros. unfold shrximm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. exists x; split; auto. + destruct x; simpl in H0; try discriminate. + destruct (Int.ltu Int.zero (Int.repr 31)); inv H0. + replace (Int.shrx i Int.zero) with i. auto. + unfold Int.shrx, Int.divs. rewrite Int.shl_zero. + change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. + econstructor; split. EvalOp. auto. +(* + intros. destruct x; simpl in H0; try discriminate. + destruct (Int.ltu n (Int.repr 31)) eqn:LTU; inv H0. + unfold shrximm. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. exists (Vint i); split; auto. + unfold Int.shrx, Int.divs. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto. + - assert (NZ: Int.unsigned n <> 0). + { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } + assert (LT: 0 <= Int.unsigned n < 31) by (apply Int.ltu_inv in LTU; assumption). + assert (LTU2: Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true). + { unfold Int.ltu; apply zlt_true. + unfold Int.sub. change (Int.unsigned Int.iwordsize) with 32. + rewrite Int.unsigned_repr. omega. + assert (32 < Int.max_unsigned) by reflexivity. omega. } + assert (X: eval_expr ge sp e m le + (Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) (a ::: Enil)) + (Vint (Int.shr i (Int.repr (Int.zwordsize - 1))))). + { EvalOp. } + assert (Y: eval_expr ge sp e m le (shrximm_inner a n) + (Vint (Int.shru (Int.shr i (Int.repr (Int.zwordsize - 1))) (Int.sub Int.iwordsize n)))). + { EvalOp. simpl. rewrite LTU2. auto. } + TrivialExists. + constructor. EvalOp. simpl; eauto. constructor. + simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int.shrx_shr_2 by auto. reflexivity. + change (Int.unsigned Int.iwordsize) with 32; omega. +*) +Qed. + +Theorem eval_shl: binary_constructor_sound shl Val.shl. +Proof. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. +Qed. + +Theorem eval_shr: binary_constructor_sound shr Val.shr. +Proof. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. +Qed. + +Theorem eval_shru: binary_constructor_sound shru Val.shru. +Proof. + red; intros until y; unfold shru; case (shru_match b); intros. + InvEval. apply eval_shruimm; auto. + TrivialExists. +Qed. + +Theorem eval_negf: unary_constructor_sound negf Val.negf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absf: unary_constructor_sound absf Val.absf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addf: binary_constructor_sound addf Val.addf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_negfs: unary_constructor_sound negfs Val.negfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absfs: unary_constructor_sound absfs Val.absfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addfs: binary_constructor_sound addfs Val.addfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subfs: binary_constructor_sound subfs Val.subfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs. +Proof. + red; intros; TrivialExists. +Qed. + +Section COMP_IMM. + +Variable default: comparison -> int -> condition. +Variable intsem: comparison -> int -> int -> bool. +Variable sem: comparison -> val -> val -> val. + +Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y). +Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef. +Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y). +Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)). +Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m). + +Lemma eval_compimm: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v + /\ Val.lessdef (sem c x (Vint n2)) v. +Proof. + intros until x. + unfold compimm; case (compimm_match c a); intros. +(* constant *) + - InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. +(* eq cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + exists (Vint Int.zero); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* ne cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + exists (Vint Int.one); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* default *) + - TrivialExists. simpl. rewrite sem_default. auto. +Qed. + +Hypothesis sem_swap: + forall c x y, sem (swap_comparison c) x y = sem c y x. + +Lemma eval_compimm_swap: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v + /\ Val.lessdef (sem c (Vint n2) x) v. +Proof. + intros. rewrite <- sem_swap. eapply eval_compimm; eauto. +Qed. + +End COMP_IMM. + +Theorem eval_comp: + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). +Proof. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. + +Theorem eval_compfs: + forall c, binary_constructor_sound (compfs c) (Val.cmpfs c). +Proof. + intros; red; intros. unfold compfs. TrivialExists. +Qed. + +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. + +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. + +Theorem eval_intoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intoffloat. TrivialExists. +Qed. + +Theorem eval_intuoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuoffloat. TrivialExists. +Qed. + +Theorem eval_floatofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofintu. case (floatofintu_match a); intros. + InvEval. simpl in H0. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_floatofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofint. case (floatofint_match a); intros. + InvEval. simpl in H0. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_intofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intofsingle. TrivialExists. +Qed. + +Theorem eval_singleofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofint x = Some y -> + exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. +Proof. + intros; unfold singleofint; TrivialExists. +Qed. + +Theorem eval_intuofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. +Qed. + +Theorem eval_singleofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofintu x = Some y -> + exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. +Qed. + +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. + +Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. +Proof. + red; intros. unfold floatofsingle. TrivialExists. +Qed. + +Theorem eval_addressing: + forall le chunk a v b ofs, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + match addressing chunk a with (mode, args) => + exists vl, + eval_exprlist ge sp e m le args vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros; InvEval. + - exists (@nil val); split. eauto with evalexpr. simpl. auto. + - destruct (Archi.pic_code tt). + + exists (Vptr b ofs0 :: nil); split. + constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. + + exists (@nil val); split. constructor. simpl; auto. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. + simpl. auto. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. + simpl. auto. + - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. +Qed. + +Theorem eval_builtin_arg: + forall a v, + eval_expr ge sp e m nil a v -> + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. +Proof. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. simpl in H5. inv H5. constructor. +- InvEval. subst v. constructor; auto. +- inv H. InvEval. simpl in H6; inv H6. constructor; auto. +- destruct Archi.ptr64 eqn:SF. ++ constructor; auto. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vint n) else Val.add v1 (Vint n)). + repeat constructor; auto. + rewrite SF; auto. +- destruct Archi.ptr64 eqn:SF. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vlong n) else Val.add v1 (Vlong n)). + repeat constructor; auto. + rewrite SF; auto. ++ constructor; auto. +- constructor; auto. +Qed. + +End CMCONSTR. diff --git a/mppa_k1c/Stacklayout.v b/mppa_k1c/Stacklayout.v new file mode 100644 index 00000000..d0c6a526 --- /dev/null +++ b/mppa_k1c/Stacklayout.v @@ -0,0 +1,147 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import AST Memory Separation. +Require Import Bounds. + +Local Open Scope sep_scope. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- Space for outgoing arguments to function calls. +- Back link to parent frame +- Return address +- Saved values of callee-save registers used by the function. +- Local stack slots. +- Space for the stack-allocated data declared in Cminor. + +The stack pointer is kept 16-aligned. +*) + +Definition fe_ofs_arg := 0. + +Definition make_env (b: bounds) : frame_env := + let w := if Archi.ptr64 then 8 else 4 in + let olink := align (4 * b.(bound_outgoing)) w in (* back link *) + let oretaddr := olink + w in (* return address *) + let ocs := oretaddr + w in (* callee-saves *) + let ol := align (size_callee_save_area b ocs) 8 in (* locals *) + let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 16 in + {| fe_size := sz; + fe_ofs_link := olink; + fe_ofs_retaddr := oretaddr; + fe_ofs_local := ol; + fe_ofs_callee_save := ocs; + fe_stack_data := ostkdata; + fe_used_callee_save := b.(used_callee_save) |}. + +Lemma frame_env_separated: + forall b sp m P, + let fe := make_env b in + m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> + m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) + ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) + ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) + ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) + ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) + ** P. +Proof. +Local Opaque Z.add Z.mul sepconj range. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). +(* Reorder as: + outgoing + back link + retaddr + callee-save + local *) + rewrite sep_swap12. + rewrite sep_swap23. + rewrite sep_swap34. + rewrite sep_swap45. +(* Apply range_split and range_split2 repeatedly *) + unfold fe_ofs_arg. + apply range_split_2. fold olink; omega. omega. + apply range_split. omega. + apply range_split. omega. + apply range_split_2. fold ol. omega. omega. + apply range_drop_right with ostkdata. omega. + eapply sep_drop2. eexact H. +Qed. + +Lemma frame_env_range: + forall b, + let fe := make_env b in + 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). + split. omega. apply align_le. omega. +Qed. + +Lemma frame_env_aligned: + forall b, + let fe := make_env b in + (8 | fe_ofs_arg) + /\ (8 | fe_ofs_local fe) + /\ (8 | fe_stack_data fe) + /\ (align_chunk Mptr | fe_ofs_link fe) + /\ (align_chunk Mptr | fe_ofs_retaddr fe). +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). + split. apply Z.divide_0_r. + split. apply align_divides; omega. + split. apply align_divides; omega. + split. apply align_divides; omega. + apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. +Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml new file mode 100644 index 00000000..696bc87f --- /dev/null +++ b/mppa_k1c/TargetPrinter.ml @@ -0,0 +1,657 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* Printing RISC-V assembly code in asm syntax *) + +open Printf +open Camlcoq +open Sections +open AST +open Asm +open PrintAsmaux +open Fileinfo + +(* Module containing the printing functions *) + +module Target : TARGET = + struct + +(* Basic printing functions *) + + let comment = "#" + + let symbol = elf_symbol + let symbol_offset = elf_symbol_offset + let label = elf_label + + let print_label oc lbl = label oc (transl_label lbl) + + let use_abi_name = false + + let int_reg_num_name = function + | X1 -> "x1" | X2 -> "x2" | X3 -> "x3" + | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7" + | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11" + | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15" + | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19" + | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23" + | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27" + | X28 -> "x28" | X29 -> "x29" | X30 -> "x30" | X31 -> "x31" + + let int_reg_abi_name = function + | X1 -> "ra" | X2 -> "sp" | X3 -> "gp" + | X4 -> "tp" | X5 -> "t0" | X6 -> "t1" | X7 -> "t2" + | X8 -> "s0" | X9 -> "s1" | X10 -> "a0" | X11 -> "a1" + | X12 -> "a2" | X13 -> "a3" | X14 -> "a4" | X15 -> "a5" + | X16 -> "a6" | X17 -> "a7" | X18 -> "s2" | X19 -> "s3" + | X20 -> "s4" | X21 -> "s5" | X22 -> "s6" | X23 -> "s7" + | X24 -> "s8" | X25 -> "s9" | X26 -> "s10" | X27 -> "s11" + | X28 -> "t3" | X29 -> "t4" | X30 -> "t5" | X31 -> "t6" + + let float_reg_num_name = function + | F0 -> "f0" | F1 -> "f1" | F2 -> "f2" | F3 -> "f3" + | F4 -> "f4" | F5 -> "f5" | F6 -> "f6" | F7 -> "f7" + | F8 -> "f8" | F9 -> "f9" | F10 -> "f10" | F11 -> "f11" + | F12 -> "f12" | F13 -> "f13" | F14 -> "f14" | F15 -> "f15" + | F16 -> "f16" | F17 -> "f17" | F18 -> "f18" | F19 -> "f19" + | F20 -> "f20" | F21 -> "f21" | F22 -> "f22" | F23 -> "f23" + | F24 -> "f24" | F25 -> "f25" | F26 -> "f26" | F27 -> "f27" + | F28 -> "f28" | F29 -> "f29" | F30 -> "f30" | F31 -> "f31" + + let float_reg_abi_name = function + | F0 -> "ft0" | F1 -> "ft1" | F2 -> "ft2" | F3 -> "ft3" + | F4 -> "ft4" | F5 -> "ft5" | F6 -> "ft6" | F7 -> "ft7" + | F8 -> "fs0" | F9 -> "fs1" | F10 -> "fa0" | F11 -> "fa1" + | F12 -> "fa2" | F13 -> "fa3" | F14 -> "fa4" | F15 -> "fa5" + | F16 -> "fa6" | F17 -> "fa7" | F18 -> "fs2" | F19 -> "fs3" + | F20 -> "fs4" | F21 -> "fs5" | F22 -> "fs6" | F23 -> "fs7" + | F24 -> "fs8" | F25 -> "fs9" | F26 ->"fs10" | F27 -> "fs11" + | F28 -> "ft3" | F29 -> "ft4" | F30 -> "ft5" | F31 -> "ft6" + + let int_reg_name = if use_abi_name then int_reg_abi_name else int_reg_num_name + let float_reg_name = if use_abi_name then float_reg_abi_name else float_reg_num_name + + let ireg oc r = output_string oc (int_reg_name r) + let freg oc r = output_string oc (float_reg_name r) + + let ireg0 oc = function + | X0 -> output_string oc "x0" + | X r -> ireg oc r + + let preg oc = function + | IR r -> ireg oc r + | FR r -> freg oc r + | _ -> assert false + + let preg_annot = function + | IR r -> int_reg_name r + | FR r -> float_reg_name r + | _ -> assert false + +(* Names of sections *) + + let name_of_section = function + | Section_text -> ".text" + | Section_data i | Section_small_data i -> + if i then ".data" else "COMM" + | Section_const i | Section_small_const i -> + if i then ".section .rodata" else "COMM" + | Section_string -> ".section .rodata" + | Section_literal -> ".section .rodata" + | Section_jumptable -> ".section .rodata" + | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" + | Section_user(s, wr, ex) -> + sprintf ".section \"%s\",\"a%s%s\",%%progbits" + s (if wr then "w" else "") (if ex then "x" else "") + | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + + let section oc sec = + fprintf oc " %s\n" (name_of_section sec) + +(* Associate labels to floating-point constants and to symbols. *) + + let emit_constants oc lit = + if exists_constants () then begin + section oc lit; + if Hashtbl.length literal64_labels > 0 then + begin + fprintf oc " .align 3\n"; + Hashtbl.iter + (fun bf lbl -> fprintf oc "%a: .quad 0x%Lx\n" label lbl bf) + literal64_labels + end; + if Hashtbl.length literal32_labels > 0 then + begin + fprintf oc " .align 2\n"; + Hashtbl.iter + (fun bf lbl -> + fprintf oc "%a: .long 0x%lx\n" label lbl bf) + literal32_labels + end; + reset_literals () + end + +(* Generate code to load the address of id + ofs in register r *) + + let loadsymbol oc r id ofs = + if Archi.pic_code () then begin + assert (ofs = Integers.Ptrofs.zero); + fprintf oc " la %a, %s\n" ireg r (extern_atom id) + end else begin + fprintf oc " lui %a, %%hi(%a)\n" + ireg r symbol_offset (id, ofs); + fprintf oc " addi %a, %a, %%lo(%a)\n" + ireg r ireg r symbol_offset (id, ofs) + end + +(* Emit .file / .loc debugging directives *) + + let print_file_line oc file line = + print_file_line oc comment file line + +(* + let print_location oc loc = + if loc <> Cutil.no_loc then print_file_line oc (fst loc) (snd loc) +*) + +(* Add "w" suffix to 32-bit instructions if we are in 64-bit mode *) + + let w oc = + if Archi.ptr64 then output_string oc "w" + +(* Offset part of a load or store *) + + let offset oc = function + | Ofsimm n -> ptrofs oc n + | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) + +(* Printing of instructions *) + let print_instruction oc = function + | Pmv(rd, rs) -> + fprintf oc " mv %a, %a\n" ireg rd ireg rs + + (* 32-bit integer register-immediate instructions *) + | Paddiw (rd, rs, imm) -> + fprintf oc " addi%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + | Psltiw (rd, rs, imm) -> + fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint imm + | Psltiuw (rd, rs, imm) -> + fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg0 rs coqint imm + | Pandiw (rd, rs, imm) -> + fprintf oc " andi %a, %a, %a\n" ireg rd ireg0 rs coqint imm + | Poriw (rd, rs, imm) -> + fprintf oc " ori %a, %a, %a\n" ireg rd ireg0 rs coqint imm + | Pxoriw (rd, rs, imm) -> + fprintf oc " xori %a, %a, %a\n" ireg rd ireg0 rs coqint imm + | Pslliw (rd, rs, imm) -> + fprintf oc " slli%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + | Psrliw (rd, rs, imm) -> + fprintf oc " srli%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + | Psraiw (rd, rs, imm) -> + fprintf oc " srai%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + | Pluiw (rd, imm) -> + fprintf oc " lui %a, %a\n" ireg rd coqint imm + + (* 32-bit integer register-register instructions *) + | Paddw(rd, rs1, rs2) -> + fprintf oc " add%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Psubw(rd, rs1, rs2) -> + fprintf oc " sub%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + + | Pmulw(rd, rs1, rs2) -> + fprintf oc " mul%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Pmulhw(rd, rs1, rs2) -> assert (not Archi.ptr64); + fprintf oc " mulh %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pmulhuw(rd, rs1, rs2) -> assert (not Archi.ptr64); + fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Pdivw(rd, rs1, rs2) -> + fprintf oc " div%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Pdivuw(rd, rs1, rs2) -> + fprintf oc " divu%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Premw(rd, rs1, rs2) -> + fprintf oc " rem%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Premuw(rd, rs1, rs2) -> + fprintf oc " remu%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + + | Psltw(rd, rs1, rs2) -> + fprintf oc " slt %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psltuw(rd, rs1, rs2) -> + fprintf oc " sltu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Pandw(rd, rs1, rs2) -> + fprintf oc " and %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Porw(rd, rs1, rs2) -> + fprintf oc " or %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pxorw(rd, rs1, rs2) -> + fprintf oc " xor %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psllw(rd, rs1, rs2) -> + fprintf oc " sll%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Psrlw(rd, rs1, rs2) -> + fprintf oc " srl%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + | Psraw(rd, rs1, rs2) -> + fprintf oc " sra%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + + (* 64-bit integer register-immediate instructions *) + | Paddil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " addi %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Psltil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Psltiul (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Pandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " andi %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Poril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " ori %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Pxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " xori %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Psllil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " slli %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Psrlil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " srli %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Psrail (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " srai %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + | Pluil (rd, imm) -> assert Archi.ptr64; + fprintf oc " lui %a, %a\n" ireg rd coqint64 imm + + (* 64-bit integer register-register instructions *) + | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " add %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psubl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " sub %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Pmull(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " mul %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pmulhl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " mulh %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pmulhul(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Pdivl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " div %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pdivul(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " divu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Preml(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " rem %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Premul(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " remu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Psltl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " slt %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psltul(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " sltu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " and %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Porl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " or %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pxorl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " xor %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Pslll(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " sll %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psrll(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " srl %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + | Psral(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " sra %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + + (* Unconditional jumps. Links are always to X1/RA. *) + (* TODO: fix up arguments for calls to variadics, to move *) + (* floating point arguments to integer registers. How? *) + | Pj_l(l) -> + fprintf oc " j %a\n" print_label l + | Pj_s(s, sg) -> + fprintf oc " j %a\n" symbol s + | Pj_r(r, sg) -> + fprintf oc " jr %a\n" ireg r + | Pjal_s(s, sg) -> + fprintf oc " call %a\n" symbol s + | Pjal_r(r, sg) -> + fprintf oc " jalr %a\n" ireg r + + (* Conditional branches, 32-bit comparisons *) + | Pbeqw(rs1, rs2, l) -> + fprintf oc " beq %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbnew(rs1, rs2, l) -> + fprintf oc " bne %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbltw(rs1, rs2, l) -> + fprintf oc " blt %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbltuw(rs1, rs2, l) -> + fprintf oc " bltu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbgew(rs1, rs2, l) -> + fprintf oc " bge %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbgeuw(rs1, rs2, l) -> + fprintf oc " bgeu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + + (* Conditional branches, 64-bit comparisons *) + | Pbeql(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " beq %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbnel(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " bne %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbltl(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " blt %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbltul(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " bltu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbgel(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " bge %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + | Pbgeul(rs1, rs2, l) -> assert Archi.ptr64; + fprintf oc " bgeu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + + (* Loads and stores *) + | Plb(rd, ra, ofs) -> + fprintf oc " lb %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Plbu(rd, ra, ofs) -> + fprintf oc " lbu %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Plh(rd, ra, ofs) -> + fprintf oc " lh %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Plhu(rd, ra, ofs) -> + fprintf oc " lhu %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) -> + fprintf oc " lw %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Pld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " ld %a, %a(%a)\n" ireg rd offset ofs ireg ra + + | Psb(rd, ra, ofs) -> + fprintf oc " sb %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Psh(rd, ra, ofs) -> + fprintf oc " sh %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) -> + fprintf oc " sw %a, %a(%a)\n" ireg rd offset ofs ireg ra + | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " sd %a, %a(%a)\n" ireg rd offset ofs ireg ra + + + (* Synchronization *) + | Pfence -> + fprintf oc " fence\n" + + (* floating point register move. + fmv.d preserves single-precision register contents, and hence + is applicable to both single- and double-precision moves. + *) + | Pfmv (fd,fs) -> + fprintf oc " fmv.d %a, %a\n" freg fd freg fs + | Pfmvxs (rd,fs) -> + fprintf oc " fmv.x.s %a, %a\n" ireg rd freg fs + | Pfmvxd (rd,fs) -> + fprintf oc " fmv.x.d %a, %a\n" ireg rd freg fs + + (* 32-bit (single-precision) floating point *) + | Pfls (fd, ra, ofs) -> + fprintf oc " flw %a, %a(%a)\n" freg fd offset ofs ireg ra + | Pfss (fs, ra, ofs) -> + fprintf oc " fsw %a, %a(%a)\n" freg fs offset ofs ireg ra + + | Pfnegs (fd, fs) -> + fprintf oc " fneg.s %a, %a\n" freg fd freg fs + | Pfabss (fd, fs) -> + fprintf oc " fabs.s %a, %a\n" freg fd freg fs + + | Pfadds (fd, fs1, fs2) -> + fprintf oc " fadd.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfsubs (fd, fs1, fs2) -> + fprintf oc " fsub.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmuls (fd, fs1, fs2) -> + fprintf oc " fmul.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfdivs (fd, fs1, fs2) -> + fprintf oc " fdiv.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmins (fd, fs1, fs2) -> + fprintf oc " fmin.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmaxs (fd, fs1, fs2) -> + fprintf oc " fmax.s %a, %a, %a\n" freg fd freg fs1 freg fs2 + + | Pfeqs (rd, fs1, fs2) -> + fprintf oc " feq.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 + | Pflts (rd, fs1, fs2) -> + fprintf oc " flt.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 + | Pfles (rd, fs1, fs2) -> + fprintf oc " fle.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 + + | Pfsqrts (fd, fs) -> + fprintf oc " fsqrt.s %a, %a\n" freg fd freg fs + + | Pfmadds (fd, fs1, fs2, fs3) -> + fprintf oc " fmadd.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfmsubs (fd, fs1, fs2, fs3) -> + fprintf oc " fmsub.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfnmadds (fd, fs1, fs2, fs3) -> + fprintf oc " fnmadd.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfnmsubs (fd, fs1, fs2, fs3) -> + fprintf oc " fnmsub.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + + | Pfcvtws (rd, fs) -> + fprintf oc " fcvt.w.s %a, %a, rtz\n" ireg rd freg fs + | Pfcvtwus (rd, fs) -> + fprintf oc " fcvt.wu.s %a, %a, rtz\n" ireg rd freg fs + | Pfcvtsw (fd, rs) -> + fprintf oc " fcvt.s.w %a, %a\n" freg fd ireg0 rs + | Pfcvtswu (fd, rs) -> + fprintf oc " fcvt.s.wu %a, %a\n" freg fd ireg0 rs + + | Pfcvtls (rd, fs) -> assert Archi.ptr64; + fprintf oc " fcvt.l.s %a, %a, rtz\n" ireg rd freg fs + | Pfcvtlus (rd, fs) -> assert Archi.ptr64; + fprintf oc " fcvt.lu.s %a, %a, rtz\n" ireg rd freg fs + | Pfcvtsl (fd, rs) -> assert Archi.ptr64; + fprintf oc " fcvt.s.l %a, %a\n" freg fd ireg0 rs + | Pfcvtslu (fd, rs) -> assert Archi.ptr64; + fprintf oc " fcvt.s.lu %a, %a\n" freg fd ireg0 rs + + (* 64-bit (double-precision) floating point *) + | Pfld (fd, ra, ofs) | Pfld_a (fd, ra, ofs) -> + fprintf oc " fld %a, %a(%a)\n" freg fd offset ofs ireg ra + | Pfsd (fs, ra, ofs) | Pfsd_a (fs, ra, ofs) -> + fprintf oc " fsd %a, %a(%a)\n" freg fs offset ofs ireg ra + + | Pfnegd (fd, fs) -> + fprintf oc " fneg.d %a, %a\n" freg fd freg fs + | Pfabsd (fd, fs) -> + fprintf oc " fabs.d %a, %a\n" freg fd freg fs + + | Pfaddd (fd, fs1, fs2) -> + fprintf oc " fadd.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfsubd (fd, fs1, fs2) -> + fprintf oc " fsub.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmuld (fd, fs1, fs2) -> + fprintf oc " fmul.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfdivd (fd, fs1, fs2) -> + fprintf oc " fdiv.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmind (fd, fs1, fs2) -> + fprintf oc " fmin.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + | Pfmaxd (fd, fs1, fs2) -> + fprintf oc " fmax.d %a, %a, %a\n" freg fd freg fs1 freg fs2 + + | Pfeqd (rd, fs1, fs2) -> + fprintf oc " feq.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 + | Pfltd (rd, fs1, fs2) -> + fprintf oc " flt.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 + | Pfled (rd, fs1, fs2) -> + fprintf oc " fle.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 + + | Pfsqrtd (fd, fs) -> + fprintf oc " fsqrt.d %a, %a\n" freg fd freg fs + + | Pfmaddd (fd, fs1, fs2, fs3) -> + fprintf oc " fmadd.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfmsubd (fd, fs1, fs2, fs3) -> + fprintf oc " fmsub.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfnmaddd (fd, fs1, fs2, fs3) -> + fprintf oc " fnmadd.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + | Pfnmsubd (fd, fs1, fs2, fs3) -> + fprintf oc " fnmsub.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 + + | Pfcvtwd (rd, fs) -> + fprintf oc " fcvt.w.d %a, %a, rtz\n" ireg rd freg fs + | Pfcvtwud (rd, fs) -> + fprintf oc " fcvt.wu.d %a, %a, rtz\n" ireg rd freg fs + | Pfcvtdw (fd, rs) -> + fprintf oc " fcvt.d.w %a, %a\n" freg fd ireg0 rs + | Pfcvtdwu (fd, rs) -> + fprintf oc " fcvt.d.wu %a, %a\n" freg fd ireg0 rs + + | Pfcvtld (rd, fs) -> assert Archi.ptr64; + fprintf oc " fcvt.l.d %a, %a, rtz\n" ireg rd freg fs + | Pfcvtlud (rd, fs) -> assert Archi.ptr64; + fprintf oc " fcvt.lu.d %a, %a, rtz\n" ireg rd freg fs + | Pfcvtdl (fd, rs) -> assert Archi.ptr64; + fprintf oc " fcvt.d.l %a, %a\n" freg fd ireg0 rs + | Pfcvtdlu (fd, rs) -> assert Archi.ptr64; + fprintf oc " fcvt.d.lu %a, %a\n" freg fd ireg0 rs + + | Pfcvtds (fd, fs) -> + fprintf oc " fcvt.d.s %a, %a\n" freg fd freg fs + | Pfcvtsd (fd, fs) -> + fprintf oc " fcvt.s.d %a, %a\n" freg fd freg fs + + (* Pseudo-instructions expanded in Asmexpand *) + | Pallocframe(sz, ofs) -> + assert false + | Pfreeframe(sz, ofs) -> + assert false + | Pseqw _ | Psnew _ | Pseql _ | Psnel _ | Pcvtl2w _ | Pcvtw2l _ -> + assert false + + (* Pseudo-instructions that remain *) + | Plabel lbl -> + fprintf oc "%a:\n" print_label lbl + | Ploadsymbol(rd, id, ofs) -> + loadsymbol oc rd id ofs + | Ploadsymbol_high(rd, id, ofs) -> + fprintf oc " lui %a, %%hi(%a)\n" ireg rd symbol_offset (id, ofs) + | Ploadli(rd, n) -> + let d = camlint64_of_coqint n in + let lbl = label_literal64 d in + fprintf oc " ld %a, %a %s %Lx\n" ireg rd label lbl comment d + | Ploadfi(rd, f) -> + let d = camlint64_of_coqint(Floats.Float.to_bits f) in + let lbl = label_literal64 d in + fprintf oc " fld %a, %a, x31 %s %.18g\n" + freg rd label lbl comment (camlfloat_of_coqfloat f) + | Ploadsi(rd, f) -> + let s = camlint_of_coqint(Floats.Float32.to_bits f) in + let lbl = label_literal32 s in + fprintf oc " flw %a, %a, x31 %s %.18g\n" + freg rd label lbl comment (camlfloat_of_coqfloat32 f) + | Pbtbl(r, tbl) -> + let lbl = new_label() in + fprintf oc "%s jumptable [ " comment; + List.iter (fun l -> fprintf oc "%a " print_label l) tbl; + fprintf oc "]\n"; + fprintf oc " sll x5, %a, 2\n" ireg r; + fprintf oc " la x31, %a\n" label lbl; + fprintf oc " add x5, x31, x5\n"; + fprintf oc " lw x5, 0(x5)\n"; + fprintf oc " add x5, x31, x5\n"; + fprintf oc " jr x5\n"; + jumptables := (lbl, tbl) :: !jumptables; + fprintf oc "%s end pseudoinstr btbl\n" comment + | Pbuiltin(ef, args, res) -> + begin match ef with + | EF_annot(kind,txt, targs) -> + let annot = + begin match (P.to_int kind) with + | 1 -> annot_text preg_annot "sp" (camlstring_of_coqstring txt) args + | 2 -> let lbl = new_label () in + fprintf oc "%a: " label lbl; + ais_annot_text lbl preg_annot "r1" (camlstring_of_coqstring txt) args + | _ -> assert false + end in + fprintf oc "%s annotation: %S\n" comment annot + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg_annot "sp" oc + (P.to_int kind) (extern_atom txt) args + | EF_inline_asm(txt, sg, clob) -> + fprintf oc "%s begin inline assembly\n\t" comment; + print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + fprintf oc "%s end inline assembly\n" comment + | _ -> + assert false + end + + let get_section_names name = + let (text, lit) = + match C2C.atom_sections name with + | t :: l :: _ -> (t, l) + | _ -> (Section_text, Section_literal) in + text,lit,Section_jumptable + + let print_align oc alignment = + fprintf oc " .balign %d\n" alignment + + let print_jumptable oc jmptbl = + let print_tbl oc (lbl, tbl) = + fprintf oc "%a:\n" label lbl; + List.iter + (fun l -> fprintf oc " .long %a - %a\n" + print_label l label lbl) + tbl in + if !jumptables <> [] then + begin + section oc jmptbl; + fprintf oc " .balign 4\n"; + List.iter (print_tbl oc) !jumptables; + jumptables := [] + end + + let print_fun_info = elf_print_fun_info + + let print_optional_fun_info _ = () + + let print_var_info = elf_print_var_info + + let print_comm_symb oc sz name align = + if C2C.atom_is_static name then + fprintf oc " .local %a\n" symbol name; + fprintf oc " .comm %a, %s, %d\n" + symbol name + (Z.to_string sz) + align + + let print_instructions oc fn = + current_function_sig := fn.fn_sig; + List.iter (print_instruction oc) fn.fn_code + + +(* Data *) + + let address = if Archi.ptr64 then ".quad" else ".long" + + let print_prologue oc = + fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); + if !Clflags.option_g then begin + section oc Section_text; + end + + let print_epilogue oc = + if !Clflags.option_g then begin + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + end + + let default_falignment = 2 + + let cfi_startproc oc = () + let cfi_endproc oc = () + + end + +let sel_target () = + (module Target:TARGET) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v new file mode 100644 index 00000000..5670b5fe --- /dev/null +++ b/mppa_k1c/ValueAOp.v @@ -0,0 +1,218 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op RTL ValueDomain. + +(** Value analysis for RISC V operators *) + +Definition eval_static_condition (cond: condition) (vl: list aval): abool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 + | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) + | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) + | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 + | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) + | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) + | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) + | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) + | _, _ => Bnone + end. + +Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := + match addr, vl with + | Aindexed n, v1::nil => offset_ptr v1 n + | Aglobal s ofs, nil => Ptr (Gl s ofs) + | Ainstack ofs, nil => Ptr (Stk ofs) + | _, _ => Vbot + end. + +Definition eval_static_operation (op: operation) (vl: list aval): aval := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Olongconst n, nil => L n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop + | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop + | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs) + | Oaddrstack ofs, nil => Ptr (Stk ofs) + | Ocast8signed, v1 :: nil => sign_ext 8 v1 + | Ocast16signed, v1 :: nil => sign_ext 16 v1 + | Oadd, v1::v2::nil => add v1 v2 + | Oaddimm n, v1::nil => add v1 (I n) + | Oneg, v1::nil => neg v1 + | Osub, v1::v2::nil => sub v1 v2 + | Omul, v1::v2::nil => mul v1 v2 + | Omulhs, v1::v2::nil => mulhs v1 v2 + | Omulhu, v1::v2::nil => mulhu v1 v2 + | Odiv, v1::v2::nil => divs v1 v2 + | Odivu, v1::v2::nil => divu v1 v2 + | Omod, v1::v2::nil => mods v1 v2 + | Omodu, v1::v2::nil => modu v1 v2 + | Oand, v1::v2::nil => and v1 v2 + | Oandimm n, v1::nil => and v1 (I n) + | Oor, v1::v2::nil => or v1 v2 + | Oorimm n, v1::nil => or v1 (I n) + | Oxor, v1::v2::nil => xor v1 v2 + | Oxorimm n, v1::nil => xor v1 (I n) + | Oshl, v1::v2::nil => shl v1 v2 + | Oshlimm n, v1::nil => shl v1 (I n) + | Oshr, v1::v2::nil => shr v1 v2 + | Oshrimm n, v1::nil => shr v1 (I n) + | Oshru, v1::v2::nil => shru v1 v2 + | Oshruimm n, v1::nil => shru v1 (I n) + | Oshrximm n, v1::nil => shrx v1 (I n) + | Omakelong, v1::v2::nil => longofwords v1 v2 + | Olowlong, v1::nil => loword v1 + | Ohighlong, v1::nil => hiword v1 + | Ocast32signed, v1::nil => longofint v1 + | Ocast32unsigned, v1::nil => longofintu v1 + | Oaddl, v1::v2::nil => addl v1 v2 + | Oaddlimm n, v1::nil => addl v1 (L n) + | Onegl, v1::nil => negl v1 + | Osubl, v1::v2::nil => subl v1 v2 + | Omull, v1::v2::nil => mull v1 v2 + | Omullhs, v1::v2::nil => mullhs v1 v2 + | Omullhu, v1::v2::nil => mullhu v1 v2 + | Odivl, v1::v2::nil => divls v1 v2 + | Odivlu, v1::v2::nil => divlu v1 v2 + | Omodl, v1::v2::nil => modls v1 v2 + | Omodlu, v1::v2::nil => modlu v1 v2 + | Oandl, v1::v2::nil => andl v1 v2 + | Oandlimm n, v1::nil => andl v1 (L n) + | Oorl, v1::v2::nil => orl v1 v2 + | Oorlimm n, v1::nil => orl v1 (L n) + | Oxorl, v1::v2::nil => xorl v1 v2 + | Oxorlimm n, v1::nil => xorl v1 (L n) + | Oshll, v1::v2::nil => shll v1 v2 + | Oshllimm n, v1::nil => shll v1 (I n) + | Oshrl, v1::v2::nil => shrl v1 v2 + | Oshrlimm n, v1::nil => shrl v1 (I n) + | Oshrlu, v1::v2::nil => shrlu v1 v2 + | Oshrluimm n, v1::nil => shrlu v1 (I n) + | Oshrxlimm n, v1::nil => shrxl v1 (I n) + | Onegf, v1::nil => negf v1 + | Oabsf, v1::nil => absf v1 + | Oaddf, v1::v2::nil => addf v1 v2 + | Osubf, v1::v2::nil => subf v1 v2 + | Omulf, v1::v2::nil => mulf v1 v2 + | Odivf, v1::v2::nil => divf v1 v2 + | Onegfs, v1::nil => negfs v1 + | Oabsfs, v1::nil => absfs v1 + | Oaddfs, v1::v2::nil => addfs v1 v2 + | Osubfs, v1::v2::nil => subfs v1 v2 + | Omulfs, v1::v2::nil => mulfs v1 v2 + | Odivfs, v1::v2::nil => divfs v1 v2 + | Osingleoffloat, v1::nil => singleoffloat v1 + | Ofloatofsingle, v1::nil => floatofsingle v1 + | Ointoffloat, v1::nil => intoffloat v1 + | Ointuoffloat, v1::nil => intuoffloat v1 + | Ofloatofint, v1::nil => floatofint v1 + | Ofloatofintu, v1::nil => floatofintu v1 + | Ointofsingle, v1::nil => intofsingle v1 + | Ointuofsingle, v1::nil => intuofsingle v1 + | Osingleofint, v1::nil => singleofint v1 + | Osingleofintu, v1::nil => singleofintu v1 + | Olongoffloat, v1::nil => longoffloat v1 + | Olonguoffloat, v1::nil => longuoffloat v1 + | Ofloatoflong, v1::nil => floatoflong v1 + | Ofloatoflongu, v1::nil => floatoflongu v1 + | Olongofsingle, v1::nil => longofsingle v1 + | Olonguofsingle, v1::nil => longuofsingle v1 + | Osingleoflong, v1::nil => singleoflong v1 + | Osingleoflongu, v1::nil => singleoflongu v1 + | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | _, _ => Vbot + end. + +Section SOUNDNESS. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. + +Theorem eval_static_condition_sound: + forall cond vargs m aargs, + list_forall2 (vmatch bc) vargs aargs -> + cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). +Proof. + intros until aargs; intros VM. inv VM. + destruct cond; auto with va. + inv H0. + destruct cond; simpl; eauto with va. + inv H2. + destruct cond; simpl; eauto with va. + destruct cond; auto with va. +Qed. + +Lemma symbol_address_sound: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). +Proof. + intros; apply symbol_address_sound; apply GENV. +Qed. + +Lemma symbol_address_sound_2: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. + constructor. constructor. apply GENV; auto. + constructor. +Qed. + +Hint Resolve symbol_address_sound symbol_address_sound_2: va. + +Ltac InvHyps := + match goal with + | [H: None = Some _ |- _ ] => discriminate + | [H: Some _ = Some _ |- _] => inv H + | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , + H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps + | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps + | _ => idtac + end. + +Theorem eval_static_addressing_sound: + forall addr vargs vres aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing addr aargs). +Proof. + unfold eval_addressing, eval_static_addressing; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. +Qed. + +Theorem eval_static_operation_sound: + forall op vargs m vres aargs, + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_operation op aargs). +Proof. + unfold eval_operation, eval_static_operation; intros; + destruct op; InvHyps; eauto with va. + destruct (propagate_float_constants tt); constructor. + destruct (propagate_float_constants tt); constructor. + rewrite Ptrofs.add_zero_l; eauto with va. + apply of_optbool_sound. eapply eval_static_condition_sound; eauto. +Qed. + +End SOUNDNESS. + diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v new file mode 100644 index 00000000..c9a1040a --- /dev/null +++ b/mppa_k1c/extractionMachdep.v @@ -0,0 +1,27 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Additional extraction directives specific to the RISC-V port *) + +Require Archi Asm. + +(* Archi *) + +Extract Constant Archi.ptr64 => " Configuration.model = ""64"" ". +Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) + +(* Asm *) +Extract Constant Asm.low_half => "fun _ _ _ -> assert false". +Extract Constant Asm.high_half => "fun _ _ _ -> assert false". -- cgit From f1d3dbb3fa70233d1ad83ae88876dd384346a16a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 22 Feb 2018 16:57:02 +0100 Subject: Changed ptr64 to be always true --- mppa_k1c/Archi.v | 2 +- mppa_k1c/Asmgenproof1.v | 4 ++-- mppa_k1c/ConstpropOpproof.v | 2 -- mppa_k1c/Op.v | 6 ++---- mppa_k1c/SelectLongproof.v | 4 ---- mppa_k1c/SelectOpproof.v | 17 ++--------------- 6 files changed, 7 insertions(+), 28 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index a1664262..bbe66c5b 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -20,7 +20,7 @@ Require Import ZArith. Require Import Fappli_IEEE. Require Import Fappli_IEEE_bits. -Parameter ptr64 : bool. +Definition ptr64 := true. Definition big_endian := false. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 7f070c12..8bbdbd4c 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -553,9 +553,9 @@ Lemma transl_cond_int32s_correct: Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. + split; intros; Simpl. destruct (rs##r1); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. + split; intros; Simpl. destruct (rs##r1); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. split; intros; Simpl. - econstructor; split. diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v index 765aa035..b6c73281 100644 --- a/mppa_k1c/ConstpropOpproof.v +++ b/mppa_k1c/ConstpropOpproof.v @@ -201,7 +201,6 @@ Proof. predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. exists (e#r); split; auto. destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. - destruct Archi.ptr64; auto. exists (Val.add e#r (Vint n)); split; auto. Qed. @@ -374,7 +373,6 @@ Proof. predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. exists (e#r); split; auto. destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. - destruct Archi.ptr64; auto. exists (Val.addl e#r (Vlong n)); split; auto. Qed. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index bb04f786..74101f53 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -522,7 +522,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* addrsymbol *) - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... (* addrstack *) - - destruct sp... apply Val.Vptr_has_type. + - destruct sp... (* castsigned *) - destruct v0... - destruct v0... @@ -532,8 +532,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* neg, sub *) - destruct v0... - unfold Val.sub. destruct v0; destruct v1... - unfold Val.has_type; destruct Archi.ptr64... - destruct Archi.ptr64... destruct (eq_block b b0)... (* mul, mulhs, mulhu *) - destruct v0; destruct v1... - destruct v0; destruct v1... @@ -582,7 +580,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... - unfold Val.subl. destruct v0; destruct v1... unfold Val.has_type; destruct Archi.ptr64... - destruct Archi.ptr64... destruct (eq_block b b0)... + destruct (eq_block b b0)... (* mull, mullhs, mullhu *) - destruct v0; destruct v1... - destruct v0; destruct v1... diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 78a1935d..511dee92 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -123,7 +123,6 @@ Proof. predSpec Int64.eq Int64.eq_spec n Int64.zero. subst. exists x; split; auto. destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. - destruct Archi.ptr64; auto. destruct (addlimm_match a); InvEval. - econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. - econstructor; split. EvalOp. simpl; eauto. @@ -169,7 +168,6 @@ Proof. destruct Archi.ptr64 eqn:SF; auto. apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. - destruct Archi.ptr64 eqn:SF; auto. - subst. econstructor; split. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. destruct sp; simpl; auto. @@ -177,7 +175,6 @@ Proof. destruct Archi.ptr64 eqn:SF; auto. apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. rewrite Ptrofs.add_commut. auto with ptrofs. - destruct Archi.ptr64 eqn:SF; auto. - subst. replace (Val.addl (Val.addl v1 (Vlong n1)) y) with (Val.addl (Val.addl v1 y) (Vlong n1)). @@ -346,7 +343,6 @@ Proof. subst x. destruct v1; simpl; auto. simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. rewrite (Int64.mul_commut n). auto. - destruct Archi.ptr64; simpl; auto. - apply eval_mullimm_base; auto. Qed. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 90f077db..e7577fb5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -143,15 +143,12 @@ Proof. - subst n. intros. exists x; split; auto. destruct x; simpl; auto. rewrite Int.add_zero; auto. - destruct Archi.ptr64; auto. rewrite Ptrofs.add_zero; auto. - case (addimm_match a); intros; InvEval; simpl. + TrivialExists; simpl. rewrite Int.add_commut. auto. + 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. + econstructor; split. EvalOp. simpl; eauto. - destruct sp; simpl; auto. destruct Archi.ptr64; auto. - rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut m0). auto. + destruct sp; simpl; auto. + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + TrivialExists. Qed. @@ -171,18 +168,10 @@ Proof. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. rewrite Val.add_commut. destruct sp; simpl; auto. destruct v1; simpl; auto. - destruct Archi.ptr64 eqn:SF; auto. - apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. - rewrite (Ptrofs.add_commut (Ptrofs.of_int n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. - destruct Archi.ptr64 eqn:SF; auto. - subst. econstructor; split. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. destruct sp; simpl; auto. destruct v1; simpl; auto. - destruct Archi.ptr64 eqn:SF; auto. - apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. - rewrite Ptrofs.add_commut. auto with ptrofs. - destruct Archi.ptr64 eqn:SF; auto. - subst. replace (Val.add (Val.add v1 (Vint n1)) y) with (Val.add (Val.add v1 y) (Vint n1)). @@ -889,8 +878,7 @@ Proof. constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. + exists (@nil val); split. constructor. simpl; auto. - 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 v1; simpl in H; try discriminate. - exists (v1 :: nil); split. eauto with evalexpr. simpl. destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. simpl. auto. @@ -917,7 +905,6 @@ Proof. - destruct Archi.ptr64 eqn:SF. + InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vlong n) else Val.add v1 (Vlong n)). repeat constructor; auto. - rewrite SF; auto. + constructor; auto. - constructor; auto. Qed. -- cgit From 917859721f6423b24788ec6219774b5196b02ec1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 1 Mar 2018 14:45:06 +0100 Subject: MPPA - Machregs + Conventions1 + backend proof tweaking --- mppa_k1c/Conventions1.v | 94 ++++++++++--------------------- mppa_k1c/Machregs.v | 145 ++++++++++++++++++++---------------------------- 2 files changed, 89 insertions(+), 150 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index df7ddfd2..400168ab 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -32,62 +32,37 @@ Require Import AST Machregs Locations. of callee- and caller-save registers. *) -Definition is_callee_save (r: mreg) : bool := +Definition is_callee_save (r: mreg): bool := match r with - | R5 | R6 | R7 => false - | R8 | R9 => true - | R10 | R11 | R12 | R13 | R14 | R15 | R16 | R17 => false - | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 => true - | R28 | R29 | R30 => false - | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 => false - | F8 | F9 => true - | F10 | F11 | F12 | F13 | F14 | F15 | F16 | F17 => false - | F18 | F19 | F20 | F21 | F22 | F23 | F24 | F25 | F26 | F27 => true - | F28 | F29 | F30 | F31 => false + | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 + | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true + | _ => false end. Definition int_caller_save_regs := - R5 :: R6 :: R7 :: - R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: - R28 :: R29 :: R30 :: - nil. + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 + :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 + :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 + :: R62 :: R63 :: nil. -Definition float_caller_save_regs := - F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: - F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: - F28 :: F29 :: F30 :: F31 :: - nil. +Definition float_caller_save_regs := @nil mreg. Definition int_callee_save_regs := - R8 :: R9 :: - R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: - nil. + R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 + :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. -Definition float_callee_save_regs := - F8 :: F9 :: - F18 :: F19 :: F20 :: F21 :: F22 :: F23 :: F24 :: F25 :: F26 :: F27 :: - nil. +Definition float_callee_save_regs := @nil mreg. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -Definition dummy_int_reg := R6. (**r Used in [Coloring]. *) -Definition dummy_float_reg := F0 . (**r Used in [Coloring]. *) +Definition dummy_int_reg := R0. (**r Used in [Coloring]. *) +Definition dummy_float_reg := R0. (**r Used in [Coloring]. *) Definition callee_save_type := mreg_type. -Definition is_float_reg (r: mreg) := - match r with - | R5 | R6 | R7 | R8 | R9 | R10 | R11 - | R12 | R13 | R14 | R15 | R16 | R17 | R18 | R19 - | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 - | R28 | R29 | R30 => false - - | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 - | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 - | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 - | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true - end. +Definition is_float_reg (r: mreg) := false. (** * Function calling conventions *) @@ -115,12 +90,12 @@ Definition is_float_reg (r: mreg) := with one integer result. *) Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R10 - | Some (Tint | Tany32) => One R10 - | Some (Tfloat | Tsingle | Tany64) => One F10 - | Some Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10 - end. + 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 + end. (** The result registers have types compatible with that given in the signature. *) @@ -157,7 +132,6 @@ Proof. intros. unfold loc_result; destruct (sig_res sg) as [[]|]; auto. unfold mreg_type; destruct Archi.ptr64; auto. - split; auto. congruence. Qed. (** The location of the result depends only on the result part of the signature *) @@ -204,10 +178,8 @@ and reserving the corresponding integer registers, so that fixup code can be introduced in the Asmexpand pass. *) -Definition int_param_regs := - R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. -Definition float_param_regs := - F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: nil. +Definition param_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil. Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) (rec: Z -> Z -> list (rpair loc)) := @@ -246,6 +218,8 @@ Fixpoint loc_arguments_rec (va: bool) (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil + | ty :: tys => one_arg param_regs r ofs ty (loc_arguments_rec va tys) +(* | (Tint | Tany32) as ty :: tys => one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) | Tsingle as ty :: tys => @@ -258,6 +232,7 @@ Fixpoint loc_arguments_rec (va: bool) if va && negb Archi.ptr64 then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys) else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) +*) end. (** [loc_arguments s] returns the list of locations where to store arguments @@ -352,32 +327,23 @@ Proof. - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l. - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega. } - assert (D: OKREGS int_param_regs). + assert (D: OKREGS param_regs). { red. decide_goal. } - assert (E: OKREGS float_param_regs). + assert (E: OKREGS param_regs). { red. decide_goal. } cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). unfold OK. eauto. - induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. -- red; simpl; tauto. -- destruct ty1. -+ (* int *) apply A; auto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. - red; simpl; tauto. - destruct ty1. + (* int *) apply A; auto. + (* float *) - destruct (va && negb Archi.ptr64). - apply C; auto. apply A; auto. + (* long *) - destruct Archi.ptr64. apply A; auto. - apply B; auto. + (* single *) apply A; auto. + (* any32 *) apply A; auto. + (* any64 *) - destruct (va && negb Archi.ptr64). - apply C; auto. apply A; auto. Qed. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index d8bb4a4b..fe39471a 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -39,37 +39,27 @@ Require Import Op. *) Inductive mreg: Type := - (** Allocatable integer regs. *) - | R5: mreg | R6: mreg | R7: mreg - | R8: mreg | R9: mreg | R10: mreg | R11: mreg - | R12: mreg | R13: mreg | R14: mreg | R15: mreg - | R16: mreg | R17: mreg | R18: mreg | R19: mreg - | R20: mreg | R21: mreg | R22: mreg | R23: mreg - | R24: mreg | R25: mreg | R26: mreg | R27: mreg - | R28: mreg | R29: mreg | R30: mreg - (** Allocatable double-precision float regs *) - | F0: mreg | F1: mreg | F2: mreg | F3: mreg - | F4: mreg | F5: mreg | F6: mreg | F7: mreg - | F8: mreg | F9: mreg | F10: mreg | F11: mreg - | F12: mreg | F13: mreg | F14: mreg | F15: mreg - | F16: mreg | F17: mreg | F18: mreg | F19: mreg - | F20: mreg | F21: mreg | F22: mreg | F23: mreg - | F24: mreg | F25: mreg | F26: mreg | F27: mreg - | F28: mreg | F29: mreg | F30: mreg | F31: mreg. + (* Allocatable General Purpose regs. *) + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 + (* R10 to R14 are reserved *) | R15 | R16 | R17 | R18 | R19 + | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 + | R30 | R31 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 + | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 + | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 + | R60 | R61 | R62 | R63. Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. Proof. decide equality. Defined. Global Opaque mreg_eq. Definition all_mregs := - R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15 - :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 - :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 - :: F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 - :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 - :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23 - :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 - :: nil. + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R15 :: R16 :: R17 :: R18 :: R19 + :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 + :: R30 :: R31 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 + :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 + :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 + :: R60 :: R61 :: R62 :: R63 :: nil. Lemma all_mregs_complete: forall (r: mreg), In r all_mregs. @@ -85,18 +75,7 @@ Instance Finite_mreg : Finite mreg := { Finite_elements_spec := all_mregs_complete }. -Definition mreg_type (r: mreg): typ := - match r with - | R5 | R6 | R7 | R8 | R9 | R10 | R11 - | R12 | R13 | R14 | R15 | R16 | R17 | R18 | R19 - | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 - | R28 | R29 | R30 => if Archi.ptr64 then Tany64 else Tany32 - - | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 - | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 - | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 - | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => Tany64 - end. +Definition mreg_type (r: mreg): typ := Tany64. Open Scope positive_scope. @@ -105,23 +84,19 @@ Module IndexedMreg <: INDEXED_TYPE. Definition eq := mreg_eq. Definition index (r: mreg): positive := match r with - | R5 => 1 | R6 => 2 | R7 => 3 - | R8 => 4 | R9 => 5 | R10 => 6 | R11 => 7 - | R12 => 8 | R13 => 9 | R14 => 10 | R15 => 11 - | R16 => 12 | R17 => 13 | R18 => 14 | R19 => 15 - | R20 => 16 | R21 => 17 | R22 => 18 | R23 => 19 - | R24 => 20 | R25 => 21 | R26 => 22 | R27 => 23 - | R28 => 24 | R29 => 25 | R30 => 26 - - | F0 => 28 | F1 => 29 | F2 => 30 | F3 => 31 - | F4 => 32 | F5 => 33 | F6 => 34 | F7 => 35 - | F8 => 36 | F9 => 37 | F10 => 38 | F11 => 39 - | F12 => 40 | F13 => 41 | F14 => 42 | F15 => 43 - | F16 => 44 | F17 => 45 | F18 => 46 | F19 => 47 - | F20 => 48 | F21 => 49 | F22 => 50 | F23 => 51 - | F24 => 52 | F25 => 53 | F26 => 54 | F27 => 55 - | F28 => 56 | F29 => 57 | F30 => 58 | F31 => 59 - end. + R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 + | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 + | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 + | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 + | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 + | R30 => 31 | R31 => 32 | R32 => 33 | R33 => 34 | R34 => 35 + | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 + | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 + | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 + | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 + | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 + | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 end. + Lemma index_inj: forall r1 r2, index r1 = index r2 -> r1 = r2. Proof. @@ -136,23 +111,18 @@ Definition is_stack_reg (r: mreg) : bool := false. Local Open Scope string_scope. Definition register_names := - ("X5", R5) :: ("X6", R6) :: ("X7", R7) :: - ("X8", R8) :: ("X9", R9) :: ("X10", R10) :: ("X11", R11) :: - ("X12", R12) :: ("X13", R13) :: ("X14", R14) :: ("X15", R15) :: - ("X16", R16) :: ("X17", R17) :: ("X18", R18) :: ("X19", R19) :: - ("X20", R20) :: ("X21", R21) :: ("X22", R22) :: ("X23", R23) :: - ("X24", R24) :: ("X25", R25) :: ("X26", R26) :: ("X27", R27) :: - ("X28", R28) :: ("X29", R29) :: ("X30", R30) :: - - ("F0", F0) :: ("F1", F1) :: ("F2", F2) :: ("F3", F3) :: - ("F4", F4) :: ("F5", F5) :: ("F6", F6) :: ("F7", F7) :: - ("F8", F8) :: ("F9", F9) :: ("F10", F10) :: ("F11", F11) :: - ("F12", F12) :: ("F13", F13) :: ("F14", F14) :: ("F15", F15) :: - ("F16", F16) :: ("F17", F17) :: ("F18", F18) :: ("F19", F19) :: - ("F20", F20) :: ("F21", F21) :: ("F22", F22) :: ("F23", F23) :: - ("F24", F24) :: ("F25", F25) :: ("F26", F26) :: ("F27", F27) :: - ("F28", F28) :: ("F29", F29) :: ("F30", F30) :: ("F31", F31) :: - nil. + ("R0", R0) :: ("R1", R1) :: ("R2", R2) :: ("R3", R3) :: ("R4", R4) + :: ("R5", R5) :: ("R6", R6) :: ("R7", R7) :: ("R8", R8) :: ("R9", R9) + :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) + :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) + :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) + :: ("R30", R30) :: ("R31", R31) :: ("R32", R32) :: ("R33", R33) :: ("R34", R34) + :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) + :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) + :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) + :: ("R50", R50) :: ("R51", R51) :: ("R52", R52) :: ("R53", R53) :: ("R54", R54) + :: ("R55", R55) :: ("R56", R56) :: ("R57", R57) :: ("R58", R58) :: ("R59", R59) + :: ("R60", R60) :: ("R61", R61) :: ("R62", R62) :: ("R63", R63) :: nil. Definition register_by_name (s: string) : option mreg := let fix assoc (l: list (string * mreg)) : option mreg := @@ -164,13 +134,14 @@ Definition register_by_name (s: string) : option mreg := (** ** Destroyed registers, preferred registers *) -Definition destroyed_by_op (op: operation): list mreg := - match op with +Definition destroyed_by_op (op: operation): list mreg := nil. +(*match op with | Ointoffloat | Ointuoffloat | Ointofsingle | Ointuofsingle | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle => F6 :: nil | _ => nil - end. + end. *) + Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. @@ -178,7 +149,8 @@ Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mre Definition destroyed_by_cond (cond: condition): list mreg := nil. -Definition destroyed_by_jumptable: list mreg := R5 :: nil. +(* Definition destroyed_by_jumptable: list mreg := R5 :: nil. *) +Definition destroyed_by_jumptable: list mreg := nil. Fixpoint destroyed_by_clobber (cl: list string): list mreg := match cl with @@ -193,23 +165,24 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil + (* | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil *) | _ => nil end. Definition destroyed_by_setstack (ty: typ): list mreg := nil. -Definition destroyed_at_function_entry: list mreg := R30 :: nil. +(* Definition destroyed_at_function_entry: list mreg := R30 :: nil. *) +Definition destroyed_at_function_entry: list mreg := nil. -Definition temp_for_parent_frame: mreg := R30. +Definition temp_for_parent_frame: mreg := R8. (* FIXME - and R9 ?? *) -Definition destroyed_at_indirect_call: list mreg := - R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. +Definition destroyed_at_indirect_call: list mreg := nil. + (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). -Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := - match ef with +Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). + (* match ef with | EF_builtin name sg => if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) @@ -217,7 +190,7 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list( (nil, nil) | _ => (nil, nil) - end. + end. *) Global Opaque destroyed_by_op destroyed_by_load destroyed_by_store @@ -232,11 +205,11 @@ Global Opaque integers as their 64-bit sign extension; and [Ocast32unsigned], because it builds on the same magic no-op. *) -Definition two_address_op (op: operation) : bool := - match op with +Definition two_address_op (op: operation) : bool := false. + (* match op with | Ocast32signed | Ocast32unsigned => true | _ => false - end. + end. *) (** Constraints on constant propagation for builtins *) -- cgit From a80a8b9ee92c9dd015d53d8de03b99c0d228d390 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 2 Mar 2018 17:19:15 +0100 Subject: MPPA - Started Asm.v + Asmgen.v, commenting out some instructions --- mppa_k1c/Asm.v | 164 +++++++++++++++++++++------------------------ mppa_k1c/Asmgen.v | 173 ++++++++++++++++++++++++------------------------ mppa_k1c/Asmgenproof1.v | 148 ++++++++++++++++++++--------------------- mppa_k1c/Conventions1.v | 4 +- mppa_k1c/Machregs.v | 9 +-- 5 files changed, 245 insertions(+), 253 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 4cd3b1fd..21e088fd 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -33,53 +33,43 @@ Require Import Conventions. (** * Abstract syntax *) -(** Integer registers. X0 is treated specially because it always reads - as zero and is never used as a destination of an instruction. *) - -Inductive ireg: Type := - | X1: ireg | X2: ireg | X3: ireg | X4: ireg | X5: ireg - | X6: ireg | X7: ireg | X8: ireg | X9: ireg | X10: ireg - | X11: ireg | X12: ireg | X13: ireg | X14: ireg | X15: ireg - | X16: ireg | X17: ireg | X18: ireg | X19: ireg | X20: ireg - | X21: ireg | X22: ireg | X23: ireg | X24: ireg | X25: ireg - | X26: ireg | X27: ireg | X28: ireg | X29: ireg | X30: ireg - | X31: ireg. - -Inductive ireg0: Type := - | X0: ireg0 | X: ireg -> ireg0. - -Coercion X: ireg >-> ireg0. - -(** Floating-point registers *) - -Inductive freg: Type := - | F0: freg | F1: freg | F2: freg | F3: freg - | F4: freg | F5: freg | F6: freg | F7: freg - | F8: freg | F9: freg | F10: freg | F11: freg - | F12: freg | F13: freg | F14: freg | F15: freg - | F16: freg | F17: freg | F18: freg | F19: freg - | F20: freg | F21: freg | F22: freg | F23: freg - | F24: freg | F25: freg | F26: freg | F27: freg - | F28: freg | F29: freg | F30: freg | F31: freg. +(** General Purpose registers. *) + +Inductive gpreg: Type := + | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg + | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. + +Definition ireg := gpreg. + +Definition freg := gpreg. Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. Proof. decide equality. Defined. -Lemma ireg0_eq: forall (x y: ireg0), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. Defined. - Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. Proof. decide equality. Defined. - + (** We model the following registers of the RISC-V architecture. *) Inductive preg: Type := - | IR: ireg -> preg (**r integer registers *) - | FR: freg -> preg (**r double-precision float registers *) - | PC: preg. (**r program counter *) + | IR: gpreg -> preg (**r integer registers *) + | FR: gpreg -> preg (**r float registers *) + | RA: preg (**r return address *) + | PC: preg. (**r program counter *) -Coercion IR: ireg >-> preg. -Coercion FR: freg >-> preg. +Coercion IR: gpreg >-> preg. +Coercion FR: gpreg >-> preg. Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. @@ -93,8 +83,10 @@ Module Pregmap := EMap(PregEq). (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) -Notation "'SP'" := X2 (only parsing) : asm. -Notation "'RA'" := X1 (only parsing) : asm. +Notation "'SP'" := GPR12 (only parsing) : asm. + +(* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) +Definition ireg0 := ireg. (** Offsets for load and store instructions. An offset is either an immediate integer or the low part of a symbol. *) @@ -139,6 +131,7 @@ Definition label := positive. [Asmgen]) is careful to respect this range. *) Inductive instruction : Type := +(* | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) @@ -175,7 +168,7 @@ Inductive instruction : Type := | Psraw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) (** 64-bit integer register-immediate instructions *) - | Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) +*) | Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) (* | Psltil (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than immediate *) | Psltiul (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than unsigned immediate *) | Pandil (rd: ireg) (rs: ireg0) (imm: int64) (**r and immediate *) @@ -186,7 +179,7 @@ Inductive instruction : Type := | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) | Pluil (rd: ireg) (imm: int64) (**r load upper-immediate *) (** 64-bit integer register-register instructions *) - | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) +*) | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) | Pmull (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) @@ -213,8 +206,8 @@ Inductive instruction : Type := (* Unconditional jumps. Links are always to X1/RA. *) | Pj_l (l: label) (**r jump to label *) | Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) - | Pj_r (r: ireg) (sg: signature) (**r jump register *) - | Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) +*)| Pj_r (r: ireg) (sg: signature) (**r jump register *) +(*| Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) (* Conditional branches, 32-bit comparisons *) @@ -332,20 +325,20 @@ Inductive instruction : Type := | Pfcvtds (rd: freg) (rs: freg) (**r float32 -> float *) | Pfcvtsd (rd: freg) (rs: freg) (**r float -> float32 *) - +*) (* 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 *) +(* | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) - | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) - + -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) (* +*) (** The pseudo-instructions are the following: @@ -441,13 +434,11 @@ Definition genv := Genv.t fundef unit. Definition get0w (rs: regset) (r: ireg0) : val := match r with | X0 => Vint Int.zero - | X r => rs r end. Definition get0l (rs: regset) (r: ireg0) : val := match r with | X0 => Vlong Int64.zero - | X r => rs r end. Notation "a # b" := (a b) (at level 1, only parsing) : asm. @@ -612,7 +603,7 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := match i with - | Pmv d s => +(* | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m (** 32-bit integer register-immediate instructions *) @@ -678,9 +669,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m (** 64-bit integer register-immediate instructions *) - | Paddil d s i => +*)| Paddil d s i => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m - | Psltil d s i => +(*| Psltil d s i => Next (nextinstr (rs#d <- (Val.maketotal (Val.cmpl Clt rs###s (Vlong i))))) m | Psltiul d s i => Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt rs###s (Vlong i))))) m @@ -700,9 +691,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m (** 64-bit integer register-register instructions *) - | Paddl d s1 s2 => +*)| Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m - | Psubl d s1 s2 => +(*| Psubl d s1 s2 => Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m | Pmull d s1 s2 => Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m @@ -749,9 +740,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out goto_label f l rs m | Pj_s s sg => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pj_r r sg => +*)| Pj_r r sg => Next (rs#PC <- (rs#r)) m - | Pjal_s s sg => +(*| Pjal_s s sg => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero) #RA <- (Val.offset_ptr rs#PC Ptrofs.one) ) m @@ -919,12 +910,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.singleoffloat rs#s))) m (** Pseudo-instructions *) - | Pallocframe sz pos => +*)| Pallocframe sz pos => let (m1, stk) := Mem.alloc m 0 sz in let sp := (Vptr stk Ptrofs.zero) in match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with | None => Stuck - | Some m2 => Next (nextinstr (rs #X30 <- (rs SP) #SP <- sp #X31 <- Vundef)) m2 + | Some m2 => Next (nextinstr (rs #GPR30 <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 end | Pfreeframe sz pos => match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with @@ -934,38 +925,38 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Vptr stk ofs => match Mem.free m stk 0 sz with | None => Stuck - | Some m' => Next (nextinstr (rs#SP <- v #X31 <- Vundef)) m' + | Some m' => Next (nextinstr (rs#SP <- v #GPR31 <- Vundef)) m' end | _ => Stuck end end | Plabel lbl => Next (nextinstr rs) m - | Ploadsymbol rd s ofs => +(*| Ploadsymbol rd s ofs => Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m | Ploadsymbol_high rd s ofs => Next (nextinstr (rs#rd <- (high_half ge s ofs))) m | Ploadli rd i => - Next (nextinstr (rs#X31 <- Vundef #rd <- (Vlong i))) m + Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m | Ploadfi rd f => - Next (nextinstr (rs#X31 <- Vundef #rd <- (Vfloat f))) m + Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vfloat f))) m | Ploadsi rd f => - Next (nextinstr (rs#X31 <- Vundef #rd <- (Vsingle f))) m + Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vsingle f))) m | Pbtbl r tbl => match rs r with | Vint n => match list_nth_z tbl (Int.unsigned n) with | None => Stuck - | Some lbl => goto_label f lbl (rs#X5 <- Vundef #X31 <- Vundef) m + | Some lbl => goto_label f lbl (rs#GPR5 <- Vundef #GPR31 <- Vundef) m end | _ => Stuck end - | Pbuiltin ef args res => +*)| Pbuiltin ef args res => Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) - | Pfence +(*| Pfence | Pfmvxs _ _ | Pfmvxd _ _ @@ -986,31 +977,29 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ => Stuck - end. +*)end. (** Translation of the LTL/Linear/Mach view of machine registers to the RISC-V view. Note that no LTL register maps to [X31]. This register is reserved as temporary, to be used by the generated RV32G code. *) + (* FIXME - R31 is not there *) Definition preg_of (r: mreg) : preg := match r with - | R5 => X5 | R6 => X6 | R7 => X7 - | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11 - | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15 - | R16 => X16 | R17 => X17 | R18 => X18 | R19 => X19 - | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23 - | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27 - | R28 => X28 | R29 => X29 | R30 => X30 - - | Machregs.F0 => F0 | Machregs.F1 => F1 | Machregs.F2 => F2 | Machregs.F3 => F3 - | Machregs.F4 => F4 | Machregs.F5 => F5 | Machregs.F6 => F6 | Machregs.F7 => F7 - | Machregs.F8 => F8 | Machregs.F9 => F9 | Machregs.F10 => F10 | Machregs.F11 => F11 - | Machregs.F12 => F12 | Machregs.F13 => F13 | Machregs.F14 => F14 | Machregs.F15 => F15 - | Machregs.F16 => F16 | Machregs.F17 => F17 | Machregs.F18 => F18 | Machregs.F19 => F19 - | Machregs.F20 => F20 | Machregs.F21 => F21 | Machregs.F22 => F22 | Machregs.F23 => F23 - | Machregs.F24 => F24 | Machregs.F25 => F25 | Machregs.F26 => F26 | Machregs.F27 => F27 - | Machregs.F28 => F28 | Machregs.F29 => F29 | Machregs.F30 => F30 | Machregs.F31 => F31 + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 +(*| R10 => GPR10 | R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R32 => GPR32 | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 end. (** Extract the values of the arguments of an external call. @@ -1065,7 +1054,7 @@ Inductive step: state -> trace -> state -> Prop := rs' = nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#X31 <- Vundef))) -> + (rs#GPR31 <- Vundef))) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1094,7 +1083,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, rs PC = Vnullptr -> - rs X10 = Vint r -> + rs GPR9 = Vint r -> final_state (State rs m) r. Definition semantics (p: program) := @@ -1164,8 +1153,7 @@ Qed. Definition data_preg (r: preg) : bool := match r with - | IR RA => false - | IR X31 => false + | RA => false | IR _ => true | FR _ => true | PC => false diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index a704ed74..72822f70 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -37,8 +37,9 @@ Definition ireg_of (r: mreg) : res ireg := match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. Definition freg_of (r: mreg) : res freg := - match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.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. *) @@ -61,7 +62,7 @@ Definition make_immed32 (val: int) := *) (** Likewise, for 64-bit integer constants. *) - +*) Inductive immed64 : Type := | Imm64_single (imm: int64) | Imm64_pair (hi: int64) (lo: int64) @@ -74,7 +75,7 @@ Definition make_immed64 (val: int64) := if Int64.eq val (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) then Imm64_pair hi lo else Imm64_large val. - +(* (** 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 @@ -87,7 +88,7 @@ Definition load_hilo32 (r: ireg) (hi lo: int) k := Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with - | Imm32_single imm => Paddiw r X0 imm :: k + | Imm32_single imm => Paddiw r GPR0 imm :: k | Imm32_pair hi lo => load_hilo32 r hi lo k end. @@ -96,7 +97,7 @@ Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) (rd rs: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => opimm rd rs imm :: k - | Imm32_pair hi lo => load_hilo32 X31 hi lo (op rd rs X31 :: k) + | Imm32_pair hi lo => load_hilo32 GPR31 hi lo (op rd rs GPR31 :: k) end. Definition addimm32 := opimm32 Paddw Paddiw. @@ -109,24 +110,26 @@ Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. - + Definition loadimm64 (r: ireg) (n: int64) (k: code) := match make_immed64 n with - | Imm64_single imm => Paddil r X0 imm :: k + | Imm64_single imm => Paddil r GPR0 imm :: k | Imm64_pair hi lo => load_hilo64 r hi lo k | Imm64_large imm => Ploadli r imm :: k end. - +*) Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => opimm rd rs imm :: k - | Imm64_pair hi lo => load_hilo64 X31 hi lo (op rd rs X31 :: k) - | Imm64_large imm => Ploadli X31 imm :: op rd rs X31 :: k +(*| Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) + | Imm64_large imm => Ploadli GPR31 imm :: op rd rs GPR31 :: k +*)| _ => nil end. Definition addimm64 := opimm64 Paddl Paddil. +(* Definition andimm64 := opimm64 Pandl Pandil. Definition orimm64 := opimm64 Porl Poril. Definition xorimm64 := opimm64 Pxorl Pxoril. @@ -215,15 +218,15 @@ Definition transl_cbranch | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq n Int.zero then - transl_cbranch_int32s c r1 X0 lbl :: k + transl_cbranch_int32s c r1 GPR0 lbl :: k else - loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) + loadimm32 GPR31 n (transl_cbranch_int32s c r1 GPR31 lbl :: k)) | Ccompuimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq n Int.zero then - transl_cbranch_int32u c r1 X0 lbl :: k + transl_cbranch_int32u c r1 GPR0 lbl :: k else - loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) + loadimm32 GPR31 n (transl_cbranch_int32u c r1 GPR31 lbl :: k)) | Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cbranch_int64s c r1 r2 lbl :: k) @@ -233,31 +236,31 @@ Definition transl_cbranch | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int64.eq n Int64.zero then - transl_cbranch_int64s c r1 X0 lbl :: k + transl_cbranch_int64s c r1 GPR0 lbl :: k else - loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) + loadimm64 GPR31 n (transl_cbranch_int64s c r1 GPR31 lbl :: k)) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int64.eq n Int64.zero then - transl_cbranch_int64u c r1 X0 lbl :: k + transl_cbranch_int64u c r1 GPR0 lbl :: k else - loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) + loadimm64 GPR31 n (transl_cbranch_int64u c r1 GPR31 lbl :: k)) | Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c X31 r1 r2 in - OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + let (insn, normal) := transl_cond_float c GPR31 r1 r2 in + OK (insn :: (if normal then Pbnew GPR31 GPR0 lbl else Pbeqw GPR31 GPR0 lbl) :: k) | Cnotcompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c X31 r1 r2 in - OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + let (insn, normal) := transl_cond_float c GPR31 r1 r2 in + OK (insn :: (if normal then Pbeqw GPR31 GPR0 lbl else Pbnew GPR31 GPR0 lbl) :: k) | Ccompfs c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c X31 r1 r2 in - OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + let (insn, normal) := transl_cond_single c GPR31 r1 r2 in + OK (insn :: (if normal then Pbnew GPR31 GPR0 lbl else Pbeqw GPR31 GPR0 lbl) :: k) | Cnotcompfs c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c X31 r1 r2 in - OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + let (insn, normal) := transl_cond_single c GPR31 r1 r2 in + OK (insn :: (if normal then Pbeqw GPR31 GPR0 lbl else Pbnew GPR31 GPR0 lbl) :: k) | _, _ => Error(msg "Asmgen.transl_cond_branch") end. @@ -307,45 +310,46 @@ Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: co end. Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else + if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 GPR0 k else match cmp with - | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) + | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd GPR0 k) | Clt => sltimm32 rd r1 n k | Cle => if Int.eq n (Int.repr Int.max_signed) then loadimm32 rd Int.one k else sltimm32 rd r1 (Int.add n Int.one) k - | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) + | _ => loadimm32 GPR31 n (transl_cond_int32s cmp rd r1 GPR31 k) end. Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else + if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 GPR0 k else match cmp with | Clt => sltuimm32 rd r1 n k - | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) + | _ => loadimm32 GPR31 n (transl_cond_int32u cmp rd r1 GPR31 k) end. Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else + if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 GPR0 k else match cmp with - | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) + | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd GPR0 k) | Clt => sltimm64 rd r1 n k | Cle => if Int64.eq n (Int64.repr Int64.max_signed) then loadimm32 rd Int.one k else sltimm64 rd r1 (Int64.add n Int64.one) k - | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) + | _ => loadimm64 GPR31 n (transl_cond_int64s cmp rd r1 GPR31 k) end. Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else + if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 GPR0 k else match cmp with | Clt => sltuimm64 rd r1 n k - | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) + | _ => loadimm64 GPR31 n (transl_cond_int64u cmp rd r1 GPR31 k) end. +*) Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + (cond: condition) (rd: ireg) (args: list mreg) (k: code) : res (list instruction) := match cond, args with - | Ccomp c, a1 :: a2 :: nil => +(*| Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_int32s c rd r1 r2 k) | Ccompu c, a1 :: a2 :: nil => @@ -385,7 +389,7 @@ Definition transl_cond_op do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_single c rd r1 r2 in OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | _, _ => +*)| _, _ => Error(msg "Asmgen.transl_cond_op") end. @@ -395,10 +399,9 @@ Definition transl_cond_op Definition transl_op (op: operation) (args: list mreg) (res: mreg) (k: code) := match op, args with - | Omove, a1 :: nil => +(*| Omove, a1 :: nil => match preg_of res, preg_of a1 with | IR r, IR a => OK (Pmv r a :: k) - | FR r, FR a => OK (Pfmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end | Ointconst n, nil => @@ -410,12 +413,12 @@ Definition transl_op | Ofloatconst f, nil => do rd <- freg_of res; OK (if Float.eq_dec f Float.zero - then Pfcvtdw rd X0 :: k + then Pfcvtdw rd GPR0 :: k else Ploadfi rd f :: k) | Osingleconst f, nil => do rd <- freg_of res; OK (if Float32.eq_dec f Float32.zero - then Pfcvtsw rd X0 :: k + then Pfcvtsw rd GPR0 :: k else Ploadsi rd f :: k) | Oaddrsymbol s ofs, nil => do rd <- ireg_of res; @@ -440,7 +443,7 @@ Definition transl_op OK (addimm32 rd rs n k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psubw rd X0 rs :: k) + OK (Psubw rd GPR0 rs :: 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 :: k) @@ -504,10 +507,10 @@ Definition transl_op | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psraiw X31 rs (Int.repr 31) :: - Psrliw X31 X31 (Int.sub Int.iwordsize n) :: - Paddw X31 rs X31 :: - Psraiw rd X31 n :: k) + Psraiw GPR31 rs (Int.repr 31) :: + Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) :: + Paddw GPR31 rs GPR31 :: + Psraiw rd GPR31 n :: k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => @@ -521,15 +524,15 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) - | Oaddl, a1 :: a2 :: nil => +*)| Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 :: k) | Oaddlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm64 rd rs n k) - | Onegl, a1 :: nil => +(*| Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psubl rd X0 rs :: k) + OK (Psubl rd GPR0 rs :: k) | Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubl rd rs1 rs2 :: k) @@ -593,10 +596,10 @@ Definition transl_op | Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psrail X31 rs (Int.repr 63) :: - Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: - Paddl X31 rs X31 :: - Psrail rd X31 n :: k) + Psrail GPR31 rs (Int.repr 63) :: + Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: + Paddl GPR31 rs GPR31 :: + Psrail rd GPR31 n :: k) | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; @@ -696,13 +699,13 @@ Definition transl_op | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k - +*) | _, _ => Error(msg "Asmgen.transl_op") end. (** Accessing data in the stack frame. *) - +(* Definition indexed_memory_access (mk_instr: ireg -> offset -> instruction) (base: ireg) (ofs: ptrofs) (k: code) := @@ -711,27 +714,26 @@ Definition indexed_memory_access | Imm64_single imm => mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k | Imm64_pair hi lo => - Pluil X31 hi :: Paddl X31 base X31 :: mk_instr X31 (Ofsimm (Ptrofs.of_int64 lo)) :: k + Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k | Imm64_large imm => - Ploadli X31 imm :: Paddl X31 base X31 :: mk_instr X31 (Ofsimm Ptrofs.zero) :: k + Ploadli GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k end else match make_immed32 (Ptrofs.to_int ofs) with | Imm32_single imm => mk_instr base (Ofsimm (Ptrofs.of_int imm)) :: k | Imm32_pair hi lo => - Pluiw X31 hi :: Paddw X31 base X31 :: mk_instr X31 (Ofsimm (Ptrofs.of_int lo)) :: k + Pluiw GPR31 hi :: Paddw GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int lo)) :: k end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs k) - | Tsingle, FR rd => OK (indexed_memory_access (Pfls rd) base ofs k) - | Tfloat, FR rd => OK (indexed_memory_access (Pfld rd) base ofs k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs k) | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k) | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) - | Tany64, FR rd => OK (indexed_memory_access (Pfld_a rd) base ofs k) | _, _ => Error (msg "Asmgen.loadind") end. @@ -739,11 +741,10 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) : match ty, preg_of src with | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs k) - | Tsingle, FR rd => OK (indexed_memory_access (Pfss rd) base ofs k) - | Tfloat, FR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k) | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k) - | Tany64, FR rd => OK (indexed_memory_access (Pfsd_a rd) base ofs k) | _, _ => Error (msg "Asmgen.storeind") end. @@ -752,28 +753,28 @@ Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := indexed_memory_access (if Archi.ptr64 then Psd src else Psw src) base ofs k. - +*) (** Translation of memory accesses: loads, and stores. *) Definition transl_memory_access (mk_instr: ireg -> offset -> instruction) - (addr: addressing) (args: list mreg) (k: code) := + (addr: addressing) (args: list mreg) (k: code) : res (list instruction) := match addr, args with - | Aindexed ofs, a1 :: nil => +(*| Aindexed ofs, a1 :: nil => do rs <- ireg_of a1; OK (indexed_memory_access mk_instr rs ofs k) | Aglobal id ofs, nil => - OK (Ploadsymbol_high X31 id ofs :: mk_instr X31 (Ofslow id ofs) :: k) + OK (Ploadsymbol_high GPR31 id ofs :: mk_instr GPR31 (Ofslow id ofs) :: k) | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs k) - | _, _ => +*)| _, _ => Error(msg "Asmgen.transl_memory_access") end. Definition transl_load (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: code) := + (args: list mreg) (dst: mreg) (k: code) : res (list instruction) := match chunk with - | Mint8signed => +(*| Mint8signed => do r <- ireg_of dst; transl_memory_access (Plb r) addr args k | Mint8unsigned => @@ -797,14 +798,14 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) | Mfloat64 => do r <- freg_of dst; transl_memory_access (Pfld r) addr args k - | _ => +*)| _ => Error (msg "Asmgen.transl_load") end. Definition transl_store (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: code) := + (args: list mreg) (src: mreg) (k: code) : res (list instruction) := match chunk with - | Mint8signed | Mint8unsigned => +(*| Mint8signed | Mint8unsigned => do r <- ireg_of src; transl_memory_access (Psb r) addr args k | Mint16signed | Mint16unsigned => @@ -822,7 +823,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) | Mfloat64 => do r <- freg_of src; transl_memory_access (Pfsd r) addr args k - | _ => +*)| _ => Error (msg "Asmgen.transl_store") end. @@ -837,18 +838,18 @@ Definition make_epilogue (f: Mach.function) (k: code) := Definition transl_instr (f: Mach.function) (i: Mach.instruction) (ep: bool) (k: code) := match i with - | Mgetstack ofs ty dst => +(*| Mgetstack ofs ty dst => loadind SP ofs ty dst k | Msetstack src ofs ty => storeind src SP ofs ty k | Mgetparam ofs ty dst => (* load via the frame pointer if it is valid *) - do c <- loadind X30 ofs ty dst k; + do c <- loadind GPR30 ofs ty dst k; OK (if ep then c - else loadind_ptr SP f.(fn_link_ofs) X30 c) - | Mop op args res => + else loadind_ptr SP f.(fn_link_ofs) GPR30 c) +*)| Mop op args res => transl_op op args res k - | Mload chunk addr args dst => +(*| Mload chunk addr args dst => transl_load chunk addr args dst k | Mstore chunk addr args src => transl_store chunk addr args src k @@ -861,19 +862,21 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (make_epilogue f (Pj_r r1 sig :: k)) | Mtailcall sig (inr symb) => OK (make_epilogue f (Pj_s symb sig :: k)) - | Mbuiltin ef args res => +*)| Mbuiltin ef args res => OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => OK (Plabel lbl :: k) - | Mgoto lbl => +(*| Mgoto lbl => OK (Pj_l lbl :: k) | Mcond cond args lbl => transl_cbranch cond args lbl k | Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) - | Mreturn => +*)| Mreturn => OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k)) + | _ => + Error (msg "Asmgen.transl_instr") end. (** Translation of a code sequence *) diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 8bbdbd4c..0a67466a 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -76,19 +76,19 @@ Qed. (** Properties of registers *) -Lemma ireg_of_not_X31: - forall m r, ireg_of m = OK r -> IR r <> IR X31. +Lemma ireg_of_not_GPR31: + forall m r, ireg_of m = OK r -> IR r <> IR GPR31. Proof. - intros. erewrite <- ireg_of_eq; eauto with asmgen. + intros. erewrite <- ireg_of_eq; eauto with asmgen. destruct m; unfold preg_of; discriminate. Qed. -Lemma ireg_of_not_X31': - forall m r, ireg_of m = OK r -> r <> X31. +Lemma ireg_of_not_GPR31': + forall m r, ireg_of m = OK r -> r <> GPR31. Proof. - intros. apply ireg_of_not_X31 in H. congruence. + intros. apply ireg_of_not_GPR31 in H. congruence. Qed. -Hint Resolve ireg_of_not_X31 ireg_of_not_X31': asmgen. +Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. (** Useful simplification tactic *) @@ -154,18 +154,18 @@ Lemma opimm32_correct: (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 <> X31 -> + r1 <> GPR31 -> 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 <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> 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 X31 hi lo (op rd r1 X31 :: k) rs m) +- destruct (load_hilo32_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) as (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. @@ -200,7 +200,7 @@ Lemma loadimm64_correct: exists rs', exec_straight ge fn (loadimm64 rd n k) rs m k rs' m /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. destruct (make_immed64 n). @@ -225,18 +225,18 @@ Lemma opimm64_correct: (forall d s n rs, exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs###s (Vlong n)))) m) -> forall rd r1 n k rs, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m /\ rs'#rd = sem rs##r1 (Vlong n) - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold opimm64. generalize (make_immed64_sound n); intros E. destruct (make_immed64 n). - subst imm. econstructor; split. apply exec_straight_one. rewrite H0. simpl; eauto. auto. split. Simpl. intros; Simpl. -- destruct (load_hilo64_correct X31 hi lo (op rd r1 X31 :: k) rs m) +- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) as (rs' & A & B & C). econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. @@ -252,11 +252,11 @@ Qed. Lemma addptrofs_correct: forall rd r1 n k rs m, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). @@ -279,11 +279,11 @@ Qed. Lemma addptrofs_correct_2: forall rd r1 n k (rs: regset) m b ofs, - r1 <> X31 -> rs#r1 = Vptr b ofs -> + r1 <> GPR31 -> rs#r1 = Vptr b ofs -> 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 <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C). exists rs'; intuition eauto. @@ -377,10 +377,10 @@ Proof. rewrite <- Float32.cmp_swap. auto. Qed. -Remark branch_on_X31: +Remark branch_on_GPR31: forall normal lbl (rs: regset) m b, - rs#X31 = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = + rs#GPR31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 X0 lbl) rs m = eval_branch fn lbl rs m (Some b). Proof. intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. @@ -425,7 +425,7 @@ Lemma transl_cbranch_correct_1: exists rs', exists insn, exec_straight_opt c rs m' (insn :: k) rs' m' /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros TRANSL EVAL AG MEXT. set (vl' := map rs (map preg_of args)). @@ -440,16 +440,16 @@ Proof. - predSpec Int.eq Int.eq_spec n Int.zero. + subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. -+ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32s c0 x X31 lbl). ++ exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32s c0 x GPR31 lbl). split. constructor; eexact A. split; auto. apply transl_cbranch_int32s_correct; auto. simpl; rewrite B, C; eauto with asmgen. - predSpec Int.eq Int.eq_spec n Int.zero. + subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. -+ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32u c0 x X31 lbl). ++ exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32u c0 x GPR31 lbl). split. constructor; eexact A. split; auto. apply transl_cbranch_int32u_correct; auto. simpl; rewrite B, C; eauto with asmgen. @@ -460,20 +460,20 @@ Proof. - predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. -+ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64s c0 x X31 lbl). ++ exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64s c0 x GPR31 lbl). split. constructor; eexact A. split; auto. apply transl_cbranch_int64s_correct; auto. simpl; rewrite B, C; eauto with asmgen. - predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. -+ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64u c0 x X31 lbl). ++ exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64u c0 x GPR31 lbl). split. constructor; eexact A. split; auto. apply transl_cbranch_int64u_correct; auto. simpl; rewrite B, C; eauto with asmgen. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. +- destruct (transl_cond_float c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). assert (V: v = Val.of_bool (eqb normal b)). { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } @@ -481,7 +481,7 @@ Proof. split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. split. rewrite V; destruct normal, b; reflexivity. intros; Simpl. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. +- destruct (transl_cond_float c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). @@ -491,7 +491,7 @@ Proof. split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. split. rewrite V; destruct normal, b; reflexivity. intros; Simpl. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. +- destruct (transl_cond_single c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). assert (V: v = Val.of_bool (eqb normal b)). { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } @@ -499,7 +499,7 @@ Proof. split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. split. rewrite V; destruct normal, b; reflexivity. intros; Simpl. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. +- destruct (transl_cond_single c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). @@ -520,7 +520,7 @@ Lemma transl_cbranch_correct_true: exists rs', exists insn, exec_straight_opt c rs m' (insn :: k) rs' m' /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply transl_cbranch_correct_1 with (b := true); eauto. Qed. @@ -533,7 +533,7 @@ Lemma transl_cbranch_correct_false: Mem.extends m m' -> exists rs', exec_straight ge fn c rs m' k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. exploit transl_cbranch_correct_1; eauto. simpl. intros (rs' & insn & A & B & C). @@ -654,11 +654,11 @@ Qed. Lemma transl_condimm_int32s_correct: forall cmp rd r1 n k rs m, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold transl_condimm_int32s. predSpec Int.eq Int.eq_spec n Int.zero. @@ -666,9 +666,9 @@ Proof. exists rs'; eauto. - assert (DFL: exists rs', - exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m + exec_straight ge fn (loadimm32 GPR31 n (transl_cond_int32s cmp rd r1 GPR31 k)) rs m k rs' m /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). exists rs2; split. @@ -718,11 +718,11 @@ Qed. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold transl_condimm_int32u. predSpec Int.eq Int.eq_spec n Int.zero. @@ -730,9 +730,9 @@ Proof. exists rs'; split. eexact A. split; auto. rewrite B; auto. - assert (DFL: exists rs', - exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m + exec_straight ge fn (loadimm32 GPR31 n (transl_cond_int32u cmp rd r1 GPR31 k)) rs m k rs' m /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). exists rs2; split. @@ -752,11 +752,11 @@ Qed. Lemma transl_condimm_int64s_correct: forall cmp rd r1 n k rs m, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold transl_condimm_int64s. predSpec Int64.eq Int64.eq_spec n Int64.zero. @@ -764,9 +764,9 @@ Proof. exists rs'; eauto. - assert (DFL: exists rs', - exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m + exec_straight ge fn (loadimm64 GPR31 n (transl_cond_int64s cmp rd r1 GPR31 k)) rs m k rs' m /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). exists rs2; split. @@ -816,11 +816,11 @@ Qed. Lemma transl_condimm_int64u_correct: forall cmp rd r1 n k rs m, - r1 <> X31 -> + r1 <> GPR31 -> exists rs', exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold transl_condimm_int64u. predSpec Int64.eq Int64.eq_spec n Int64.zero. @@ -828,9 +828,9 @@ Proof. exists rs'; split. eexact A. split; auto. rewrite B; auto. - assert (DFL: exists rs', - exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m + exec_straight ge fn (loadimm64 GPR31 n (transl_cond_int64u cmp rd r1 GPR31 k)) rs m k rs' m /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). exists rs2; split. @@ -854,7 +854,7 @@ Lemma transl_cond_op_correct: exists rs', exec_straight ge fn c rs m k rs' m /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). { destruct ob as [[]|]; reflexivity. } @@ -1106,12 +1106,12 @@ Qed. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, - base <> X31 -> + base <> GPR31 -> exists base' ofs' rs', exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m (mk_instr base' ofs' :: k) rs' m /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. unfold indexed_memory_access; intros. destruct Archi.ptr64 eqn:SF. @@ -1152,11 +1152,11 @@ Lemma indexed_load_access_correct: exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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 -> - base <> X31 -> rd <> PC -> + base <> GPR31 -> rd <> PC -> exists rs', exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m /\ rs'#rd = v - /\ forall r, r <> PC -> r <> X31 -> r <> rd -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. exploit indexed_memory_access_correct; eauto. @@ -1173,10 +1173,10 @@ Lemma indexed_store_access_correct: exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> X31 -> r1 <> X31 -> r1 <> PC -> + base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> exists rs', exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. exploit indexed_memory_access_correct; eauto. @@ -1191,11 +1191,11 @@ Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - base <> X31 -> + base <> GPR31 -> exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR LOAD NOT31. assert (A: exists mk_instr, @@ -1212,10 +1212,10 @@ Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - base <> X31 -> + base <> GPR31 -> exists rs', exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros TR STORE NOT31. assert (A: exists mk_instr, @@ -1231,11 +1231,11 @@ Qed. Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> - base <> X31 -> + base <> GPR31 -> exists rs', exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m /\ rs'#dst = v - /\ forall r, r <> PC -> r <> X31 -> r <> dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. intros. unfold Mptr. destruct Archi.ptr64; auto. @@ -1244,10 +1244,10 @@ Qed. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - base <> X31 -> src <> X31 -> + base <> GPR31 -> src <> GPR31 -> exists rs', exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. destruct Archi.ptr64; auto. @@ -1260,7 +1260,7 @@ Lemma transl_memory_access_correct: exists base ofs rs', exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until v; intros TR EV. unfold transl_memory_access in TR; destruct addr; ArgsInv. @@ -1285,7 +1285,7 @@ Lemma transl_load_access_correct: exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> X31 -> r <> rd -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. Proof. intros until v'; intros INSTR TR EV LOAD NOTPC. exploit transl_memory_access_correct; eauto. @@ -1303,10 +1303,10 @@ Lemma transl_store_access_correct: 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.storev chunk m v rs#r1 = Some m' -> - r1 <> PC -> r1 <> X31 -> + r1 <> PC -> r1 <> GPR31 -> exists rs', exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros INSTR TR EV STORE NOTPC NOT31. exploit transl_memory_access_correct; eauto. @@ -1325,7 +1325,7 @@ Lemma transl_load_correct: exists rs', exec_straight ge fn c rs m k rs' m /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR EV LOAD. assert (A: exists mk_instr, @@ -1344,7 +1344,7 @@ Lemma transl_store_correct: Mem.storev chunk m a rs#(preg_of src) = Some m' -> exists rs', exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. assert (A: exists mk_instr chunk', @@ -1378,7 +1378,7 @@ Lemma make_epilogue_correct: /\ Mem.extends m' tm' /\ rs'#RA = parent_ra cs /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> X31 -> rs'#r = rs#r). + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> rs'#r = rs#r). Proof. intros until tm; intros LP LRA FREE AG MEXT MCS. exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 400168ab..42905b30 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -35,7 +35,7 @@ Require Import AST Machregs Locations. Definition is_callee_save (r: mreg): bool := match r with | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 - | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true + | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 => true | _ => false end. @@ -50,7 +50,7 @@ Definition float_caller_save_regs := @nil mreg. Definition int_callee_save_regs := R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 - :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. + :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: nil. Definition float_callee_save_regs := @nil mreg. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index fe39471a..09a6a237 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -38,12 +38,13 @@ Require Import Op. assembly-code generator [Asmgen]. *) +(* FIXME - no R31 *) Inductive mreg: Type := (* Allocatable General Purpose regs. *) | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 (* R10 to R14 are reserved *) | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 - | R30 | R31 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 + | R30 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 | R60 | R61 | R62 | R63. @@ -56,7 +57,7 @@ Definition all_mregs := R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 - :: R30 :: R31 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 + :: R30 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. @@ -89,7 +90,7 @@ Module IndexedMreg <: INDEXED_TYPE. | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 - | R30 => 31 | R31 => 32 | R32 => 33 | R33 => 34 | R34 => 35 + | R30 => 31 | R32 => 33 | R33 => 34 | R34 => 35 | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 @@ -116,7 +117,7 @@ Definition register_names := :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) - :: ("R30", R30) :: ("R31", R31) :: ("R32", R32) :: ("R33", R33) :: ("R34", R34) + :: ("R30", R30) :: ("R32", R32) :: ("R33", R33) :: ("R34", R34) :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) -- cgit From e65ce82fa66afa7d4c6b4d664fd583cf12f8ca21 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 8 Mar 2018 18:25:08 +0100 Subject: MPPA - Started restricting instructions + get/set + change ABI + trying to prove it --- mppa_k1c/Asm.v | 86 +++++++++++++++++++++++++++++++++--------------- mppa_k1c/Asmgen.v | 87 ++++++++++++++++++++++++++++++++----------------- mppa_k1c/Asmgenproof1.v | 52 +++++++++++++++++------------ 3 files changed, 147 insertions(+), 78 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 21e088fd..f5ff7c78 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -52,6 +52,12 @@ Inductive gpreg: Type := Definition ireg := gpreg. +(* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) +Inductive ireg0: Type := + | GPR: gpreg -> ireg0. + +Coercion GPR: gpreg >-> ireg0. + Definition freg := gpreg. Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. @@ -85,9 +91,6 @@ Module Pregmap := EMap(PregEq). Notation "'SP'" := GPR12 (only parsing) : asm. -(* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) -Definition ireg0 := ireg. - (** Offsets for load and store instructions. An offset is either an immediate integer or the low part of a symbol. *) @@ -131,6 +134,10 @@ Definition label := positive. [Asmgen]) is careful to respect this range. *) Inductive instruction : Type := +(** Branch Control Unit instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) (* | Pmv (rd: ireg) (rs: ireg) (**r integer move *) @@ -177,9 +184,9 @@ Inductive instruction : Type := | Psllil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) | Psrlil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) - | Pluil (rd: ireg) (imm: int64) (**r load upper-immediate *) +*)| Pluil (rd: ireg) (imm: int64) (**r load upper-immediate *) (** 64-bit integer register-register instructions *) -*) | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* + | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) | Pmull (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) @@ -206,8 +213,8 @@ Inductive instruction : Type := (* Unconditional jumps. Links are always to X1/RA. *) | Pj_l (l: label) (**r jump to label *) | Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) -*)| Pj_r (r: ireg) (sg: signature) (**r jump register *) -(*| Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) + | Pj_r (r: ireg) (sg: signature) (**r jump register *) + | Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) (* Conditional branches, 32-bit comparisons *) @@ -233,15 +240,15 @@ Inductive instruction : Type := | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int16 *) | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) +*)| Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) +(*| Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store int16 *) | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) +*)| Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) +(*| Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) (* Synchronization *) | Pfence (**r fence *) @@ -332,8 +339,8 @@ Inductive instruction : Type := | Plabel (lbl: label) (**r define a code label *) (* | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) - | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) +*)| Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) +(*| Ploadfi (rd: freg) (f: float) (**r load an immediate float *) | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) @@ -431,19 +438,31 @@ Definition program := AST.program fundef unit. Definition regset := Pregmap.t val. Definition genv := Genv.t fundef unit. -Definition get0w (rs: regset) (r: ireg0) : val := +Definition getw (rs: regset) (r: ireg0) : val := + match r with + | GPR r => rs r + end. +(* match r with | X0 => Vint Int.zero + | X r => rs r end. +*) -Definition get0l (rs: regset) (r: ireg0) : val := +Definition getl (rs: regset) (r: ireg0) : val := + match r with + | GPR r => rs r + end. +(* match r with | X0 => Vlong Int64.zero + | X r => rs r end. +*) Notation "a # b" := (a b) (at level 1, only parsing) : asm. -Notation "a ## b" := (get0w a b) (at level 1) : asm. -Notation "a ### b" := (get0l a b) (at level 1) : asm. +Notation "a ## b" := (getw a b) (at level 1) : asm. +Notation "a ### b" := (getl a b) (at level 1) : asm. Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. Open Scope asm. @@ -603,6 +622,18 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := match i with + | Pget rd ra => + match ra with + | RA => Next (nextinstr (rs#rd <- (rs#ra))) m + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (nextinstr (rs#ra <- (rs#rd))) m + | _ => Stuck + end + | Pret => + Next (rs#PC <- (rs#RA)) m (* | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m @@ -687,11 +718,11 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m | Psrail d s i => Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m - | Pluil d i => +*)| Pluil d i => Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m (** 64-bit integer register-register instructions *) -*)| Paddl d s1 s2 => + | Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m (*| Psubl d s1 s2 => Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m @@ -740,9 +771,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out goto_label f l rs m | Pj_s s sg => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m -*)| Pj_r r sg => + | Pj_r r sg => Next (rs#PC <- (rs#r)) m -(*| Pjal_s s sg => + | Pjal_s s sg => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero) #RA <- (Val.offset_ptr rs#PC Ptrofs.one) ) m @@ -791,9 +822,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mint32 rs m d a ofs | Plw_a d a ofs => exec_load Many32 rs m d a ofs - | Pld d a ofs => +*)| Pld d a ofs => exec_load Mint64 rs m d a ofs - | Pld_a d a ofs => +(*| Pld_a d a ofs => exec_load Many64 rs m d a ofs | Psb s a ofs => exec_store Mint8unsigned rs m s a ofs @@ -803,9 +834,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_store Mint32 rs m s a ofs | Psw_a s a ofs => exec_store Many32 rs m s a ofs - | Psd s a ofs => +*)| Psd s a ofs => exec_store Mint64 rs m s a ofs - | Psd_a s a ofs => +(*| Psd_a s a ofs => exec_store Many64 rs m s a ofs (** Floating point register move *) @@ -936,9 +967,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m | Ploadsymbol_high rd s ofs => Next (nextinstr (rs#rd <- (high_half ge s ofs))) m - | Ploadli rd i => +*)| Ploadli rd i => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m - | Ploadfi rd f => +(*| Ploadfi rd f => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vfloat f))) m | Ploadsi rd f => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vsingle f))) m @@ -1154,6 +1185,7 @@ Qed. Definition data_preg (r: preg) : bool := match r with | RA => false + | IR GPR31 => false (* FIXME - GPR31 is used as temporary in some instructions.. ??? *) | IR _ => true | FR _ => true | PC => false diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 72822f70..1edb209d 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -106,11 +106,11 @@ Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. - +*) Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. - +(* Definition loadimm64 (r: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => Paddil r GPR0 imm :: k @@ -123,9 +123,8 @@ Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => opimm rd rs imm :: k -(*| Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) + | Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) | Imm64_large imm => Ploadli GPR31 imm :: op rd rs GPR31 :: k -*)| _ => nil end. Definition addimm64 := opimm64 Paddl Paddil. @@ -705,27 +704,19 @@ Definition transl_op end. (** Accessing data in the stack frame. *) -(* + Definition indexed_memory_access (mk_instr: ireg -> offset -> instruction) (base: ireg) (ofs: ptrofs) (k: code) := - if Archi.ptr64 then - match make_immed64 (Ptrofs.to_int64 ofs) with - | Imm64_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k - | Imm64_pair hi lo => - Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k - | Imm64_large imm => - Ploadli GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k - end - else - match make_immed32 (Ptrofs.to_int ofs) with - | Imm32_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int imm)) :: k - | Imm32_pair hi lo => - Pluiw GPR31 hi :: Paddw GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int lo)) :: k - end. - + match make_immed64 (Ptrofs.to_int64 ofs) with + | Imm64_single imm => + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k + | Imm64_pair hi lo => + Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k + | Imm64_large imm => + Ploadli GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k + end. +(* Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) @@ -748,12 +739,13 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) : | _, _ => Error (msg "Asmgen.storeind") end. +*) Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := - indexed_memory_access (if Archi.ptr64 then Pld dst else Plw dst) base ofs k. + indexed_memory_access (Pld dst) base ofs k. Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := - indexed_memory_access (if Archi.ptr64 then Psd src else Psw src) base ofs k. -*) + indexed_memory_access (Psd src) base ofs k. + (** Translation of memory accesses: loads, and stores. *) Definition transl_memory_access @@ -829,9 +821,36 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) (** Function epilogue *) +(* +Definition store_ra (base: ireg) (ofs: ptrofs) (k: code) := + indexed_memory_access (Psd GPR8) base ofs (Pget GPR8 RA :: k) + . +*) + +(* +Definition make_ra (base: ireg) (ofs: ptrofs) (k: code) := + Pset RA GPR8 + :: (indexed_memory_access (Pld GPR8) base ofs k) (* FIXME - not sure about GPR8 *) + . +*) + +(* +Definition make_epilogue (f: Mach.function) (k: code) := + Pset RA GPR8 :: (indexed_memory_access (Pld GPR8) SP f.(fn_retaddr_ofs) (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k)) + (* make_ra SP f.(fn_retaddr_ofs) + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k) *) + . +*) + +Definition make_epilogue (f: Mach.function) (k: code) := + Pset RA GPR8 :: loadind_ptr SP f.(fn_retaddr_ofs) GPR8 + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + +(* Definition make_epilogue (f: Mach.function) (k: code) := loadind_ptr SP f.(fn_retaddr_ofs) RA (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). +*) (** Translation of a Mach instruction. *) @@ -870,11 +889,10 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (Pj_l lbl :: k) | Mcond cond args lbl => transl_cbranch cond args lbl k - | Mjumptable arg tbl => - do r <- ireg_of arg; - OK (Pbtbl r tbl :: k) + | Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) *)| Mreturn => - OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k)) + OK (make_epilogue f (Pret :: k)) + (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | _ => Error (msg "Asmgen.transl_instr") end. @@ -924,7 +942,16 @@ Definition transl_function (f: Mach.function) := do c <- transl_code' f f.(Mach.fn_code) true; OK (mkfunction f.(Mach.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - storeind_ptr RA SP f.(fn_retaddr_ofs) c)). + storeind_ptr GPR8 SP f.(fn_retaddr_ofs) (Pget GPR8 RA :: c))). + +(* +Definition transl_function (f: Mach.function) := + do c <- transl_code' f f.(Mach.fn_code) true; + OK (mkfunction f.(Mach.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: + indexed_memory_access (Psd GPR8) SP f.(fn_retaddr_ofs) (Pget GPR8 RA :: c))). + (* store_ra SP f.(fn_retaddr_ofs) c)). *) +*) Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 0a67466a..b782608b 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -21,7 +21,7 @@ Require Import Op Locations Mach Conventions. Require Import Asm Asmgen Asmgenproof0. (** Decomposition of integer constants. *) - +(* Lemma make_immed32_sound: forall n, match make_immed32 n with @@ -55,7 +55,7 @@ Proof. rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). rewrite D. apply Int.add_zero. Qed. - +*) Lemma make_immed64_sound: forall n, match make_immed64 n with @@ -79,7 +79,7 @@ Qed. Lemma ireg_of_not_GPR31: forall m r, ireg_of m = OK r -> IR r <> IR GPR31. Proof. - intros. erewrite <- ireg_of_eq; eauto with asmgen. destruct m; unfold preg_of; discriminate. + intros. erewrite <- ireg_of_eq; eauto with asmgen. Qed. Lemma ireg_of_not_GPR31': @@ -109,7 +109,7 @@ 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', @@ -175,7 +175,7 @@ Proof. Qed. (** 64-bit integer constants and arithmetic *) - +*) Lemma load_hilo64_correct: forall rd hi lo k rs m, exists rs', @@ -194,7 +194,7 @@ Proof. split. Simpl. intros; Simpl. Qed. - +(* Lemma loadimm64_correct: forall rd n k rs m, exists rs', @@ -215,7 +215,7 @@ Proof. split. Simpl. intros; Simpl. Qed. - +*) Lemma opimm64_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int64 -> instruction) @@ -249,7 +249,7 @@ Proof. Qed. (** Add offset to pointer *) - +(* Lemma addptrofs_correct: forall rd r1 n k rs m, r1 <> GPR31 -> @@ -385,7 +385,7 @@ Remark branch_on_GPR31: Proof. intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. Qed. - +*) Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -415,7 +415,7 @@ Remark exec_straight_opt_right: Proof. destruct 1; intros. auto. eapply exec_straight_trans; eauto. Qed. - +(* Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -940,7 +940,7 @@ Proof. apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. split; intros; Simpl. Qed. - +*) (** Some arithmetic properties. *) Remark cast32unsigned_from_cast32signed: @@ -980,6 +980,7 @@ Proof. Opaque Int.eq. intros until c; intros TR EV. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +(* - (* move *) destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. - (* intconst *) @@ -1069,10 +1070,12 @@ Opaque Int.eq. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. +*) - (* addlimm *) exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. + exists rs'; split; eauto. rewrite B; auto with asmgen. +(* - (* andimm *) exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). @@ -1100,6 +1103,7 @@ Opaque Int.eq. - (* cond *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. +*) Qed. (** Memory accesses *) @@ -1114,7 +1118,8 @@ Lemma indexed_memory_access_correct: /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. unfold indexed_memory_access; intros. - destruct Archi.ptr64 eqn:SF. + (* destruct Archi.ptr64 eqn:SF. *) + assert (Archi.ptr64 = true) as SF; auto. - generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. destruct (make_immed64 (Ptrofs.to_int64 ofs)). + econstructor; econstructor; econstructor; split. @@ -1132,6 +1137,7 @@ Proof. 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. @@ -1144,6 +1150,7 @@ Proof. 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: @@ -1186,7 +1193,7 @@ Proof. unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. intros; Simpl. Qed. - +(* Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> @@ -1227,7 +1234,7 @@ Proof. destruct A as (mk_instr & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. Qed. - +*) Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> @@ -1238,9 +1245,9 @@ Lemma loadind_ptr_correct: /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. - intros. unfold Mptr. destruct Archi.ptr64; auto. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto. Qed. - +(* Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> @@ -1252,7 +1259,7 @@ Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. destruct Archi.ptr64; auto. Qed. - +*) Lemma transl_memory_access_correct: forall mk_instr addr args k c (rs: regset) m v, transl_memory_access mk_instr addr args k = OK c -> @@ -1264,6 +1271,7 @@ Lemma transl_memory_access_correct: Proof. intros until v; intros TR EV. unfold transl_memory_access in TR; destruct addr; ArgsInv. +(* - (* indexed *) inv EV. apply indexed_memory_access_correct; eauto with asmgen. - (* global *) @@ -1272,6 +1280,7 @@ Proof. split; intros; Simpl. unfold eval_offset. apply low_high_half. - (* stack *) inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. +*) Qed. Lemma transl_load_access_correct: @@ -1354,16 +1363,16 @@ Proof. /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). { unfold transl_store in TR; destruct chunk; ArgsInv; (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). +(* destruct a; auto. apply Mem.store_signed_unsigned_8. destruct a; auto. apply Mem.store_signed_unsigned_16. +*) } destruct A as (mk_instr & chunk' & B & C & D). rewrite D in STORE; clear D. eapply transl_store_access_correct; eauto with asmgen. Qed. -(** Function epilogues *) - Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> @@ -1387,7 +1396,8 @@ Proof. exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). unfold make_epilogue. - rewrite chunk_of_Tptr in *. + rewrite chunk_of_Tptr in *. + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) RA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. congruence. intros (rs1 & A1 & B1 & C1). -- cgit From e3aed59a6d58f4486da40e0a7a381ea0bf10ba81 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 12 Mar 2018 18:17:09 +0100 Subject: MPPA - Preuve de make_epilogue correct. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ça va un peu plus loin! --- mppa_k1c/Asm.v | 3 ++- mppa_k1c/Asmgen.v | 7 ++++--- mppa_k1c/Asmgenproof1.v | 54 ++++++++++++++++++++++++++++++++++++++----------- mppa_k1c/Conventions1.v | 2 +- mppa_k1c/Machregs.v | 10 ++++----- 5 files changed, 54 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f5ff7c78..4122ac29 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1019,7 +1019,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 (*| R10 => GPR10 | R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 @@ -1186,6 +1186,7 @@ Definition data_preg (r: preg) : bool := match r with | RA => false | IR GPR31 => false (* FIXME - GPR31 is used as temporary in some instructions.. ??? *) + | IR GPR8 => false (* FIXME - idem *) | IR _ => true | FR _ => true | PC => false diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 1edb209d..ba9e6fe8 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -843,8 +843,8 @@ Definition make_epilogue (f: Mach.function) (k: code) := *) Definition make_epilogue (f: Mach.function) (k: code) := - Pset RA GPR8 :: loadind_ptr SP f.(fn_retaddr_ofs) GPR8 - (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + loadind_ptr SP f.(fn_retaddr_ofs) GPR8 + (Pset RA GPR8 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). (* Definition make_epilogue (f: Mach.function) (k: code) := @@ -942,7 +942,8 @@ Definition transl_function (f: Mach.function) := do c <- transl_code' f f.(Mach.fn_code) true; OK (mkfunction f.(Mach.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - storeind_ptr GPR8 SP f.(fn_retaddr_ofs) (Pget GPR8 RA :: c))). + Pget GPR8 RA :: + storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). (* Definition transl_function (f: Mach.function) := diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index b782608b..7fe9b3f7 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1235,6 +1235,22 @@ Proof. eapply indexed_store_access_correct; eauto with asmgen. Qed. *) + +Lemma Pset_correct: + forall (dst: preg) (src: gpreg) k (rs: regset) m, + dst = RA -> + exists rs', + exec_straight ge fn (Pset dst src :: k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor; simpl. + rewrite H. auto. + Simpl. + Simpl. + intros. rewrite H. Simpl. +Qed. + Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> @@ -1387,7 +1403,7 @@ Lemma make_epilogue_correct: /\ Mem.extends m' tm' /\ rs'#RA = parent_ra cs /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> rs'#r = rs#r). + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). Proof. intros until tm; intros LP LRA FREE AG MEXT MCS. exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). @@ -1398,21 +1414,35 @@ Proof. unfold make_epilogue. rewrite chunk_of_Tptr in *. - exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) RA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). - rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. congruence. - intros (rs1 & A1 & B1 & C1). - econstructor; econstructor; split. - eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. - rewrite (C1 X2) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. - rewrite FREE'. eauto. auto. - split. apply agree_nextinstr. apply agree_set_other; auto with asmgen. + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 + :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). + - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. + - congruence. + - intros (rs1 & A1 & B1 & C1). + assert (agree ms (Vptr stk soff) rs1) as AG1. + + destruct AG. + apply mkagree; auto. + rewrite C1; discriminate || auto. + intro. rewrite C1; auto; destruct r; simpl; try discriminate. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs1 tm). auto. + intros (rs2 & A2 & B2 & C2). + econstructor; econstructor; split. + * eapply exec_straight_trans. + { eexact A1. } + { eapply exec_straight_trans. + { eapply A2. } + { apply exec_straight_one. simpl. + rewrite (C2 GPR12) 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. apply agree_change_sp with (Vptr stk soff). - apply agree_exten with rs; auto. intros; apply C1; auto with asmgen. + apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. eapply parent_sp_def; eauto. split. auto. + split. Simpl. rewrite B2. auto. split. Simpl. - split. Simpl. - intros. Simpl. + intros. Simpl. + rewrite C2; auto. Qed. End CONSTRUCTORS. diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 42905b30..6bb616c8 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -40,7 +40,7 @@ Definition is_callee_save (r: mreg): bool := end. Definition int_caller_save_regs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 09a6a237..d30cdbbd 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -41,7 +41,7 @@ Require Import Op. (* FIXME - no R31 *) Inductive mreg: Type := (* Allocatable General Purpose regs. *) - | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R9 (* R10 to R14 are reserved *) | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 @@ -54,7 +54,7 @@ Proof. decide equality. Defined. Global Opaque mreg_eq. Definition all_mregs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 @@ -86,7 +86,7 @@ Module IndexedMreg <: INDEXED_TYPE. Definition index (r: mreg): positive := match r with R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 - | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 + | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 @@ -113,7 +113,7 @@ Local Open Scope string_scope. Definition register_names := ("R0", R0) :: ("R1", R1) :: ("R2", R2) :: ("R3", R3) :: ("R4", R4) - :: ("R5", R5) :: ("R6", R6) :: ("R7", R7) :: ("R8", R8) :: ("R9", R9) + :: ("R5", R5) :: ("R6", R6) :: ("R7", R7) :: ("R9", R9) :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) @@ -175,7 +175,7 @@ Definition destroyed_by_setstack (ty: typ): list mreg := nil. (* Definition destroyed_at_function_entry: list mreg := R30 :: nil. *) Definition destroyed_at_function_entry: list mreg := nil. -Definition temp_for_parent_frame: mreg := R8. (* FIXME - and R9 ?? *) +Definition temp_for_parent_frame: mreg := R9. (* FIXME - and R8 ?? *) Definition destroyed_at_indirect_call: list mreg := nil. (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) -- cgit From 79597131ae07f1fe63485270486755481549470f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 13 Mar 2018 15:53:31 +0100 Subject: MPPA - ABI proof complete (Asmgenproof.v:step_simulation) --- mppa_k1c/Asm.v | 4 +- mppa_k1c/Asmgen.v | 4 +- mppa_k1c/Asmgenproof.v | 132 +++++++++++++++++++++++++++++++++--------------- mppa_k1c/Asmgenproof1.v | 21 ++++++-- mppa_k1c/Machregs.v | 3 +- 5 files changed, 115 insertions(+), 49 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 4122ac29..22b2c7a3 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -946,7 +946,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out let sp := (Vptr stk Ptrofs.zero) in match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with | None => Stuck - | Some m2 => Next (nextinstr (rs #GPR30 <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 + | Some m2 => Next (nextinstr (rs #GPR32 <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 end | Pfreeframe sz pos => match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with @@ -1114,7 +1114,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, rs PC = Vnullptr -> - rs GPR9 = Vint r -> + rs GPR0 = Vint r -> final_state (State rs m) r. Definition semantics (p: program) := diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index ba9e6fe8..c8ea4279 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -902,8 +902,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := match i with | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst R30) - | Mop op args res => before && negb (mreg_eq res R30) + | Mgetparam ofs ty dst => negb (mreg_eq dst R32) + | Mop op args res => before && negb (mreg_eq res R32) | _ => false end. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index cc45a8de..51d093f8 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -114,7 +114,7 @@ Qed. *) Section TRANSL_LABEL. - +(* Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k). Proof. @@ -141,7 +141,7 @@ Proof. unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. Qed. Hint Resolve loadimm64_label: labels. - +*) Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -152,7 +152,7 @@ Proof. unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. Qed. Hint Resolve opimm64_label: labels. - +(* Remark addptrofs_label: forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). Proof. @@ -213,12 +213,13 @@ Proof. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. Qed. - +*) Remark transl_cond_op_label: forall cond args r k c, transl_cond_op cond r args k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +(* - destruct c0; simpl; TailNoLabel. - destruct c0; simpl; TailNoLabel. - unfold transl_condimm_int32s. @@ -267,6 +268,7 @@ Proof. - destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. +*) Qed. Remark transl_op_label: @@ -275,6 +277,10 @@ Remark transl_op_label: Proof. Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. +- apply opimm64_label; intros; exact I. +Qed. + +(* - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. - destruct (Float.eq_dec n Float.zero); TailNoLabel. - destruct (Float32.eq_dec n Float32.zero); TailNoLabel. @@ -292,7 +298,7 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. - destruct (Int.eq n Int.zero); TailNoLabel. - eapply transl_cond_op_label; eauto. -Qed. +*) Remark indexed_memory_access_label: forall (mk_instr: ireg -> offset -> instruction) base ofs k, @@ -300,11 +306,11 @@ Remark indexed_memory_access_label: tail_nolabel k (indexed_memory_access mk_instr base ofs k). Proof. unfold indexed_memory_access; intros. - destruct Archi.ptr64. + (* destruct Archi.ptr64. *) destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. - destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. + (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) Qed. - +(* Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. @@ -320,7 +326,7 @@ Proof. unfold storeind; intros. destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. Qed. - +*) Remark loadind_ptr_label: forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). Proof. @@ -354,6 +360,10 @@ Lemma transl_instr_label: match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. Proof. unfold transl_instr; intros; destruct i; TailNoLabel. +- eapply transl_op_label; eauto. +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +Qed. +(* - eapply loadind_label; eauto. - eapply storeind_label; eauto. - destruct ep. eapply loadind_label; eauto. @@ -365,7 +375,7 @@ Proof. - destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). - eapply transl_cbranch_label; eauto. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -Qed. +*) Lemma transl_instr_label': forall lbl f i ep k c, @@ -404,7 +414,7 @@ Lemma transl_find_label: Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeind_ptr_label X1 X2 (fn_retaddr_ofs f) x) as [A B]; rewrite B. + simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]; rewrite B. eapply transl_code_label; eauto. Qed. @@ -450,7 +460,7 @@ Proof. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. exists x; exists true; split; auto. unfold fn_code. - constructor. apply (storeind_ptr_label X1 X2 (fn_retaddr_ofs f0) x). + constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x). - exact transf_function_no_overflow. Qed. @@ -480,7 +490,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (MEXT: Mem.extends m m') (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) - (DXP: ep = true -> rs#X30 = parent_sp s), + (DXP: ep = true -> rs#GPR32 = parent_sp s), match_states (Mach.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -511,7 +521,7 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#X30 = parent_sp s)) -> + /\ (it1_is_parent ep i = true -> rs2#GPR32 = parent_sp s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. @@ -622,9 +632,9 @@ Definition measure (s: Mach.state) : nat := | Mach.Returnstate _ _ _ => 1%nat end. -Remark preg_of_not_X30: forall r, negb (mreg_eq r R30) = true -> IR X30 <> preg_of r. +Remark preg_of_not_GPR32: forall r, negb (mreg_eq r R32) = true -> IR GPR32 <> preg_of r. Proof. - intros. change (IR X30) with (preg_of R30). red; intros. + intros. change (IR GPR32) with (preg_of R32). red; intros. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. @@ -648,10 +658,15 @@ Proof. exploit Mem.loadv_extends; eauto. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. + inversion TR. +(* + intros [rs' [P [Q R]]]. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. exists rs'; split. eauto. split. eapply agree_set_mreg; eauto with asmgen. congruence. simpl; congruence. +*) - (* Msetstack *) unfold store_stack in H. @@ -659,11 +674,12 @@ Proof. exploit Mem.storev_extends; eauto. intros [m2' [A B]]. left; eapply exec_straight_steps; eauto. rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + inversion TR. +(*exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. exists rs'; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. simpl; intros. rewrite Q; auto with asmgen. - +*) - (* Mgetparam *) assert (f0 = f) by congruence; subst f0. unfold load_stack in *. @@ -672,8 +688,9 @@ Proof. 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. +(* Opaque loadind. *) + left; eapply exec_straight_steps; eauto; intros. monadInv TR. +(* destruct ep. (* X30 contains parent *) exploit loadind_correct. eexact EQ. @@ -696,7 +713,7 @@ Opaque loadind. intros. unfold Pregmap.set. destruct (PregEq.eq r' X30). congruence. auto with asmgen. simpl; intros. rewrite U; auto with asmgen. apply preg_of_not_X30; auto. - +*) - (* Mop *) assert (eval_operation tge sp op (map rs args) m = Some v). rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. @@ -708,7 +725,7 @@ Opaque loadind. apply agree_set_undef_mreg with rs0; auto. apply Val.lessdef_trans with v'; auto. simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_X30; auto. + rewrite R; auto. apply preg_of_not_GPR32; auto. Local Transparent destroyed_by_op. destruct op; simpl; auto; congruence. @@ -719,11 +736,14 @@ Local Transparent destroyed_by_op. intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. + inversion TR. +(*exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. exists rs2; split. eauto. split. eapply agree_set_undef_mreg; eauto. congruence. intros; auto with asmgen. simpl; congruence. +*) - (* Mstore *) assert (eval_addressing tge sp addr (map rs args) = Some a). @@ -733,17 +753,20 @@ Local Transparent destroyed_by_op. assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. exploit Mem.storev_extends; eauto. intros [m2' [C D]]. left; eapply exec_straight_steps; eauto. - intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + intros. simpl in TR. + inversion TR. +(*exploit transl_store_correct; eauto. intros [rs2 [P Q]]. exists rs2; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. - +*) - (* Mcall *) assert (f0 = f) by congruence. subst f0. inv AT. assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. destruct ros as [rf|fid]; simpl in H; monadInv H5. +(* + (* Indirect call *) assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. @@ -777,13 +800,14 @@ Local Transparent destroyed_by_op. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. rewrite <- H2. auto. - +*) - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. destruct ros as [rf|fid]; simpl in H; monadInv H7. +(* + (* Indirect call *) assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. @@ -817,7 +841,7 @@ Local Transparent destroyed_by_op. econstructor; eauto. apply agree_set_other; auto with asmgen. Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. - +*) - (* Mbuiltin *) inv AT. monadInv H4. exploit functions_transl; eauto. intro FN. @@ -847,6 +871,7 @@ Local Transparent destroyed_by_op. - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. +(* exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. left; exists (State rs' m'); split. apply plus_one. econstructor; eauto. @@ -856,30 +881,35 @@ Local Transparent destroyed_by_op. econstructor; eauto. eapply agree_exten; eauto with asmgen. congruence. - +*) - (* Mcond true *) assert (f0 = f) by congruence. subst f0. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_opt_steps_goto; eauto. intros. simpl in TR. + inversion TR. +(* exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). exists jmp; exists k; exists rs'. split. eexact A. split. apply agree_exten with rs0; auto with asmgen. exact B. - +*) - (* Mcond false *) exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps; eauto. intros. simpl in TR. + inversion TR. +(* exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). exists rs'. split. eexact A. split. apply agree_exten with rs0; auto with asmgen. simpl. congruence. - +*) - (* Mjumptable *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H6. +(* exploit functions_transl; eauto. intro FN. generalize (transf_function_no_overflow _ _ H5); intro NOOV. exploit find_label_goto_label. eauto. eauto. @@ -896,7 +926,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto. simpl. intros. rewrite C; auto with asmgen. Simpl. congruence. - +*) - (* Mreturn *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. simpl in H6; monadInv H6. @@ -930,12 +960,20 @@ Local Transparent destroyed_by_op. (* Execution of function prologue *) monadInv EQ0. rewrite transl_code'_transl_code in EQ1. set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) :: - storeind_ptr RA SP (fn_retaddr_ofs f) x0) in *. + Pget GPR8 RA :: + storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#X30 <- (parent_sp s) #SP <- sp #X31 <- Vundef)). - exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) RA x0 rs2 m2'). - rewrite chunk_of_Tptr in P. change (rs2 X1) with (rs0 X1). rewrite ATLR. - change (rs2 X2) with sp. eexact P. + set (rs2 := nextinstr (rs0#GPR32 <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). + exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } + rewrite H3. rewrite H4. + (* change (rs' GPR8) with (rs0 RA). *) + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. congruence. congruence. intros (rs3 & U & V). assert (EXEC_PROLOGUE: @@ -946,8 +984,10 @@ Local Transparent destroyed_by_op. apply exec_straight_step with rs2 m2'. unfold exec_instr. rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. - reflexivity. - eexact U. } + reflexivity. + eapply exec_straight_trans. + - eexact U'. + - eexact U. } exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. intros (ofs' & X & Y). left; exists (State rs3 m3'); split. @@ -962,7 +1002,19 @@ Local Transparent destroyed_by_op. Local Transparent destroyed_at_function_entry. simpl; intros; Simpl. unfold sp; congruence. - intros. rewrite V by auto with asmgen. reflexivity. + + intros. + assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite V. + assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H6; 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 V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. - (* external function *) exploit functions_translated; eauto. @@ -1012,7 +1064,7 @@ Lemma transf_final_states: Proof. intros. inv H0. inv H. constructor. assumption. compute in H1. inv H1. - generalize (preg_val _ _ _ R10 AG). rewrite H2. intros LD; inv LD. auto. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. Qed. Theorem transf_program_correct: diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 7fe9b3f7..c712b5e7 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1236,6 +1236,21 @@ Proof. Qed. *) +Lemma Pget_correct: + forall (dst: gpreg) (src: preg) k (rs: regset) m, + src = RA -> + exists rs', + exec_straight ge fn (Pget dst src :: k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor. +- simpl. rewrite H. auto. +- Simpl. +- Simpl. +- intros. rewrite H. Simpl. +Qed. + Lemma Pset_correct: forall (dst: preg) (src: gpreg) k (rs: regset) m, dst = RA -> @@ -1263,7 +1278,7 @@ Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto. Qed. -(* + Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> @@ -1273,9 +1288,9 @@ Lemma storeind_ptr_correct: /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. - intros. unfold Mptr. destruct Archi.ptr64; auto. + intros. unfold Mptr. assert (Archi.ptr64 = true); auto. Qed. -*) + Lemma transl_memory_access_correct: forall mk_instr addr args k c (rs: regset) m v, transl_memory_access mk_instr addr args k = OK c -> diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index d30cdbbd..ee7d91da 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -172,8 +172,7 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := Definition destroyed_by_setstack (ty: typ): list mreg := nil. -(* Definition destroyed_at_function_entry: list mreg := R30 :: nil. *) -Definition destroyed_at_function_entry: list mreg := nil. +Definition destroyed_at_function_entry: list mreg := R32 :: nil. Definition temp_for_parent_frame: mreg := R9. (* FIXME - and R8 ?? *) -- cgit From ad9f97729e9c708f8e220e6d93a1cdb442b60273 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 14 Mar 2018 11:51:48 +0100 Subject: MPPA - Removed Plui, replaced with Pmake, and modified make_immed64 --- mppa_k1c/Asm.v | 15 +++++++++------ mppa_k1c/Asmgen.v | 30 ++++++++++++++++++------------ mppa_k1c/Asmgenproof.v | 5 +++-- mppa_k1c/Asmgenproof1.v | 17 ++++++++++------- 4 files changed, 40 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 22b2c7a3..5c8a6360 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -138,11 +138,11 @@ Inductive instruction : Type := | Pget (rd: ireg) (rs: preg) (**r get system register *) | Pset (rd: preg) (rs: ireg) (**r set system register *) | Pret (**r return *) -(* + | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) - | Paddiw (rd: ireg) (rs: ireg0) (imm: int) (**r add immediate *) +(*| Paddiw (rd: ireg) (rs: ireg0) (imm: int) (**r add immediate *) | Psltiw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than immediate *) | Psltiuw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than unsigned immediate *) | Pandiw (rd: ireg) (rs: ireg0) (imm: int) (**r and immediate *) @@ -184,7 +184,8 @@ Inductive instruction : Type := | Psllil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) | Psrlil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) -*)| Pluil (rd: ireg) (imm: int64) (**r load upper-immediate *) + | Pluil (rd: ireg) (imm: int64) (**r FIXME - remove it ; load upper-immediate *) +*)| Pmake (rd: ireg) (imm: int64) (**r load immediate *) (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) @@ -634,11 +635,11 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pret => Next (rs#PC <- (rs#RA)) m -(* | Pmv d s => + | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m (** 32-bit integer register-immediate instructions *) - | Paddiw d s i => +(*| Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m | Psltiw d s i => Next (nextinstr (rs#d <- (Val.cmp Clt rs##s (Vint i)))) m @@ -718,8 +719,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m | Psrail d s i => Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m -*)| Pluil d i => + | Pluil d i => Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m +*)| Pmake d i => + Next (nextinstr (rs#d <- (Vlong i))) m (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index c8ea4279..e1c01d3f 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -65,16 +65,19 @@ Definition make_immed32 (val: int) := *) Inductive immed64 : Type := | Imm64_single (imm: int64) - | Imm64_pair (hi: int64) (lo: int64) +(*| Imm64_pair (hi: int64) (lo: int64) | Imm64_large (imm: int64). +*). -Definition make_immed64 (val: int64) := - let lo := Int64.sign_ext 12 val in +(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) +Definition make_immed64 (val: int64) := Imm64_single val. +(*let lo := Int64.sign_ext 12 val in if Int64.eq val lo then Imm64_single lo else let hi := Int64.zero_ext 20 (Int64.shru (Int64.sub val lo) (Int64.repr 12)) in if Int64.eq val (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) then Imm64_pair hi lo else Imm64_large val. +*) (* (** Smart constructors for arithmetic operations involving a 32-bit or 64-bit integer constant. Depending on whether the @@ -107,9 +110,11 @@ Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. *) +(* Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. +*) (* Definition loadimm64 (r: ireg) (n: int64) (k: code) := match make_immed64 n with @@ -123,26 +128,27 @@ Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => opimm rd rs imm :: k - | Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) +(*| Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) | Imm64_large imm => Ploadli GPR31 imm :: op rd rs GPR31 :: k - end. +*)end. Definition addimm64 := opimm64 Paddl Paddil. + (* Definition andimm64 := opimm64 Pandl Pandil. Definition orimm64 := opimm64 Porl Poril. Definition xorimm64 := opimm64 Pxorl Pxoril. Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. +*) Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then Pmv rd rs :: k else - if Archi.ptr64 - then addimm64 rd rs (Ptrofs.to_int64 n) k - else addimm32 rd rs (Ptrofs.to_int n) k. - + addimm64 rd rs (Ptrofs.to_int64 n) k. + +(* (** Translation of conditional branches. *) Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := @@ -711,11 +717,11 @@ Definition indexed_memory_access match make_immed64 (Ptrofs.to_int64 ofs) with | Imm64_single imm => mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k - | Imm64_pair hi lo => +(*| Imm64_pair hi lo => Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k | Imm64_large imm => - Ploadli GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k - end. + Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k +*)end. (* Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 51d093f8..568311f5 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -149,7 +149,7 @@ Remark opimm64_label: tail_nolabel k (opimm64 op opimm r1 r2 n k). Proof. intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. - unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) Qed. Hint Resolve opimm64_label: labels. (* @@ -414,7 +414,8 @@ Lemma transl_find_label: Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]; rewrite B. + simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. + (* destruct B. *) eapply transl_code_label; eauto. Qed. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index c712b5e7..f83275a1 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -60,9 +60,9 @@ Lemma make_immed64_sound: forall n, match make_immed64 n with | Imm64_single imm => n = imm - | Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo +(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo | Imm64_large imm => n = imm - end. +*)end. Proof. intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). predSpec Int64.eq Int64.eq_spec n lo. @@ -175,7 +175,7 @@ Proof. Qed. (** 64-bit integer constants and arithmetic *) -*) + Lemma load_hilo64_correct: forall rd hi lo k rs m, exists rs', @@ -194,7 +194,7 @@ Proof. split. Simpl. intros; Simpl. Qed. -(* + Lemma loadimm64_correct: forall rd n k rs m, exists rs', @@ -236,6 +236,7 @@ Proof. - subst imm. econstructor; split. apply exec_straight_one. rewrite H0. simpl; eauto. auto. split. Simpl. intros; Simpl. +(* - destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) as (rs' & A & B & C). econstructor; split. @@ -246,6 +247,7 @@ Proof. - 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 *) @@ -1070,12 +1072,12 @@ Opaque Int.eq. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. -*) + - (* addlimm *) exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. -(* + - (* andimm *) exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). @@ -1125,6 +1127,7 @@ Proof. + 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. @@ -1150,7 +1153,7 @@ Proof. 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: -- cgit From 74ce642ef4e223ef02369c290ca1625b7b7f912c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 15 Mar 2018 12:03:40 +0100 Subject: MPPA - Created Pmakel instruction + re-activated Oloadimm64/32 --- mppa_k1c/Asm.v | 15 +++++++------ mppa_k1c/Asmgen.v | 57 ++++++++++++++------------------------------------ mppa_k1c/Asmgenproof.v | 10 ++++----- 3 files changed, 29 insertions(+), 53 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 5c8a6360..9c85dbbd 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -185,7 +185,8 @@ Inductive instruction : Type := | Psrlil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) | Pluil (rd: ireg) (imm: int64) (**r FIXME - remove it ; load upper-immediate *) -*)| Pmake (rd: ireg) (imm: int64) (**r load immediate *) +*)| Pmake (rd: ireg) (imm: int) (**r load immediate *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) @@ -340,8 +341,8 @@ Inductive instruction : Type := | Plabel (lbl: label) (**r define a code label *) (* | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) -*)| Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) -(*| Ploadfi (rd: freg) (f: float) (**r load an immediate float *) + | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) + | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) @@ -721,8 +722,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m | Pluil d i => Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m -*)| Pmake d i => +*)| Pmakel d i => Next (nextinstr (rs#d <- (Vlong i))) m + | Pmake d i => + Next (nextinstr (rs#d <- (Vint i))) m (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => @@ -970,9 +973,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m | Ploadsymbol_high rd s ofs => Next (nextinstr (rs#rd <- (high_half ge s ofs))) m -*)| Ploadli rd i => + | Ploadli rd i => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m -(*| Ploadfi rd f => + | Ploadfi rd f => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vfloat f))) m | Ploadsi rd f => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vsingle f))) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e1c01d3f..efcafda2 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -44,57 +44,36 @@ Definition freg_of (r: mreg) : res freg := 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) - | Imm32_pair (hi: int) (lo: int). - -Definition make_immed32 (val: int) := - let lo := Int.sign_ext 12 val in - if Int.eq val lo - then Imm32_single val - else Imm32_pair (Int.shru (Int.sub val lo) (Int.repr 12)) lo. -(* - let discr := Int.shr val (Int.repr 11) in - let hi := Int.shru val (Int.repr 12) in - if Int.eq discr Int.zero || Int.eq discr Int.mone - then Imm32_single val - else Imm32_pair (Int.add hi (Int.and discr Int.one)) (Int.sign_ext 12 val). *) +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) -(*| Imm64_pair (hi: int64) (lo: int64) - | Imm64_large (imm: int64). -*). +. (* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. -(*let lo := Int64.sign_ext 12 val in - if Int64.eq val lo then Imm64_single lo else - let hi := Int64.zero_ext 20 (Int64.shru (Int64.sub val lo) (Int64.repr 12)) in - if Int64.eq val (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) - then Imm64_pair hi lo - else Imm64_large val. -*) -(* + (** 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 load_hilo32 (r: ireg) (hi lo: int) k := if Int.eq lo Int.zero then Pluiw r hi :: k else Pluiw r hi :: Paddiw r r lo :: k. - +*) Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with - | Imm32_single imm => Paddiw r GPR0 imm :: k - | Imm32_pair hi lo => load_hilo32 r hi lo k + | Imm32_single imm => Pmake r imm :: k end. - +(* Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int -> instruction) (rd rs: ireg) (n: int) (k: code) := @@ -115,22 +94,18 @@ Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. *) -(* + Definition loadimm64 (r: ireg) (n: int64) (k: code) := match make_immed64 n with - | Imm64_single imm => Paddil r GPR0 imm :: k - | Imm64_pair hi lo => load_hilo64 r hi lo k - | Imm64_large imm => Ploadli r imm :: k + | Imm64_single imm => Pmakel r imm :: k end. -*) + Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => opimm rd rs imm :: k -(*| Imm64_pair hi lo => load_hilo64 GPR31 hi lo (op rd rs GPR31 :: k) - | Imm64_large imm => Ploadli GPR31 imm :: op rd rs GPR31 :: k -*)end. +end. Definition addimm64 := opimm64 Paddl Paddil. @@ -409,13 +384,13 @@ Definition transl_op | IR r, IR a => OK (Pmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end - | Ointconst n, nil => +*)| Ointconst n, nil => do rd <- ireg_of res; OK (loadimm32 rd n k) | Olongconst n, nil => do rd <- ireg_of res; OK (loadimm64 rd n k) - | Ofloatconst f, nil => +(*| Ofloatconst f, nil => do rd <- freg_of res; OK (if Float.eq_dec f Float.zero then Pfcvtdw rd GPR0 :: k diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 568311f5..a5ea3bb9 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -114,15 +114,14 @@ Qed. *) Section TRANSL_LABEL. -(* + Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k). Proof. intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. - unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. Qed. Hint Resolve loadimm32_label: labels. - +(* Remark opimm32_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -133,15 +132,14 @@ Proof. unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. Qed. Hint Resolve opimm32_label: labels. - +*) Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). Proof. intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. - unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. Qed. Hint Resolve loadimm64_label: labels. -*) + Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> -- cgit From f677664f63ca17c0a514c449f62ad958b5f9eb68 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 15 Mar 2018 12:05:57 +0100 Subject: MPPA - The project compiles. Supports very simple programs that load integer immediates. It starts the main, loads integer in registers, and return correctly. Addition in Mach not yet supported, but should not be hard to add them. Function calls are not yet supported. The ABI for now is the same as the RiscV, with a small twist: $ra is first loaded in a user register, then this user register is pushed (instead of pushing $ra straight away). --- mppa_k1c/Asmexpand.ml | 158 +++++++++++++++++++++++++--------------------- mppa_k1c/TargetPrinter.ml | 133 +++++++++++++++++--------------------- 2 files changed, 144 insertions(+), 147 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 945974e0..fea71f61 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -42,9 +42,10 @@ let wordsize = if Archi.ptr64 then 8 else 4 let align n a = (n + a - 1) land (-a) (* Emit instruction sequences that set or offset a register by a constant. *) - -let expand_loadimm32 dst n = +(* + let expand_loadimm32 dst n = List.iter emit (Asmgen.loadimm32 dst n []) +*) let expand_addptrofs dst src n = List.iter emit (Asmgen.addptrofs dst src n []) let expand_storeind_ptr src base ofs = @@ -60,11 +61,12 @@ let expand_storeind_ptr src base ofs = (* Fix-up code around calls to variadic functions. Floating-point arguments residing in FP registers need to be moved to integer registers. *) -let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |] -let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] +let int_param_regs = [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |] +(* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) +let float_param_regs = [| |] -let rec fixup_variadic_call pos tyl = - if pos < 8 then +let fixup_variadic_call pos tyl = assert false +(*if pos < 8 then match tyl with | [] -> () @@ -98,14 +100,15 @@ let rec fixup_variadic_call pos tyl = fixup_variadic_call (pos + 2) tyl end end +*) let fixup_call sg = if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args (* Handling of annotations *) -let expand_annot_val kind txt targ args res = - emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); +let expand_annot_val kind txt targ args res = assert false +(*emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); match args, res with | [BA(IR src)], BR(IR dst) -> if dst <> src then emit (Pmv (dst, src)) @@ -113,6 +116,7 @@ let expand_annot_val kind txt targ args res = if dst <> src then emit (Pfmv (dst, src)) | _, _ -> raise (Error "ill-formed __builtin_annot_val") +*) (* Handling of memcpy *) @@ -121,20 +125,21 @@ let expand_annot_val kind txt targ args res = let offset_in_range ofs = let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L -let memcpy_small_arg sz arg tmp = - match arg with +let memcpy_small_arg sz arg tmp = assert false +(*match arg with | BA (IR r) -> (r, _0) | BA_addrstack ofs -> if offset_in_range ofs && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) - then (X2, ofs) - else begin expand_addptrofs tmp X2 ofs; (tmp, _0) end + then (GPR12, ofs) + else begin expand_addptrofs tmp GPR12 ofs; (tmp, _0) end | _ -> assert false +*) -let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = +let expand_builtin_memcpy_small sz al src dst = assert false +(*let (tsrc, tdst) = if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in @@ -164,17 +169,19 @@ let expand_builtin_memcpy_small sz al src dst = copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1) end in copy osrc odst sz +*) -let memcpy_big_arg sz arg tmp = - match arg with +let memcpy_big_arg sz arg tmp = assert false +(*match arg with | BA (IR r) -> if r <> tmp then emit (Pmv(tmp, r)) | BA_addrstack ofs -> expand_addptrofs tmp X2 ofs | _ -> assert false +*) -let expand_builtin_memcpy_big sz al src dst = - assert (sz >= al); +let expand_builtin_memcpy_big sz al src dst = assert false +(*assert (sz >= al); assert (sz mod al = 0); let (s, d) = if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in @@ -200,6 +207,7 @@ let expand_builtin_memcpy_big sz al src dst = emit store; expand_addptrofs d d delta; emit (Pbnew (X X7, X0, lbl)) +*) let expand_builtin_memcpy sz al args = let (dst, src) = @@ -210,8 +218,8 @@ let expand_builtin_memcpy sz al args = (* Handling of volatile reads and writes *) -let expand_builtin_vload_common chunk base ofs res = - match chunk, res with +let expand_builtin_vload_common chunk base ofs res = assert false +(*match chunk, res with | Mint8unsigned, BR(IR res) -> emit (Plbu (res, base, Ofsimm ofs)) | Mint8signed, BR(IR res) -> @@ -239,30 +247,32 @@ let expand_builtin_vload_common chunk base ofs res = emit (Pfld (res, base, Ofsimm ofs)) | _ -> assert false +*) -let expand_builtin_vload chunk args res = - match args with +let expand_builtin_vload chunk args res = assert false +(*match args with | [BA(IR addr)] -> expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk X2 ofs res + expand_builtin_vload_common chunk GPR12 ofs res else begin - expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) - expand_builtin_vload_common chunk X31 _0 res + expand_addptrofs GPR32 GPR12 ofs; (* X31 <- sp + ofs *) + expand_builtin_vload_common chunk GPR32 _0 res end | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs))] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vload_common chunk addr ofs res else begin - expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) - expand_builtin_vload_common chunk X31 _0 res + expand_addptrofs GPR32 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vload_common chunk GPR32 _0 res end | _ -> assert false +*) -let expand_builtin_vstore_common chunk base ofs src = - match chunk, src with +let expand_builtin_vstore_common chunk base ofs src = assert false +(*match chunk, src with | (Mint8signed | Mint8unsigned), BA(IR src) -> emit (Psb (src, base, Ofsimm ofs)) | (Mint16signed | Mint16unsigned), BA(IR src) -> @@ -281,9 +291,10 @@ let expand_builtin_vstore_common chunk base ofs src = emit (Pfsd (src, base, Ofsimm ofs)) | _ -> assert false +*) -let expand_builtin_vstore chunk args = - match args with +let expand_builtin_vstore chunk args = assert false +(*match args with | [BA(IR addr); src] -> expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> @@ -302,6 +313,7 @@ let expand_builtin_vstore chunk args = end | _ -> assert false +*) (* Handling of varargs *) @@ -322,19 +334,20 @@ let save_arguments first_reg base_ofs = for i = first_reg to 7 do expand_storeind_ptr int_param_regs.(i) - X2 + GPR12 (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))) done let vararg_start_ofs : Z.t option ref = ref None -let expand_builtin_va_start r = - match !vararg_start_ofs with +let expand_builtin_va_start r = assert false +(*match !vararg_start_ofs with | None -> invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> expand_addptrofs X31 X2 (Ptrofs.repr ofs); expand_storeind_ptr X31 r Ptrofs.zero +*) (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to two instructions, one computing the low 32 bits of the result, @@ -343,26 +356,27 @@ let expand_builtin_va_start r = instruction, we must go through X31 to hold the low 32 bits of the result. *) -let expand_int64_arith conflict rl fn = - if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl +let expand_int64_arith conflict rl fn = assert false +(*if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl *) (* Byte swaps. There are no specific instructions, so we use standard, not-very-efficient formulas. *) -let expand_bswap16 d s = +let expand_bswap16 d s = assert false (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) - emit (Pandiw(X31, X s, coqint_of_camlint 0xFFl)); +(*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)) +*) -let expand_bswap32 d s = +let expand_bswap32 d s = assert false (* d = (s << 24) | (((s >> 8) & 0xFF) << 16) | (((s >> 16) & 0xFF) << 8) | (s >> 24) *) - emit (Pslliw(X1, X s, coqint_of_camlint 24l)); +(*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)); @@ -373,8 +387,9 @@ let expand_bswap32 d s = 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 = +let expand_bswap64 d s = assert false (* d = s << 56 | (((s >> 8) & 0xFF) << 48) | (((s >> 16) & 0xFF) << 40) @@ -383,7 +398,7 @@ let expand_bswap64 d s = | (((s >> 40) & 0xFF) << 16) | (((s >> 48) & 0xFF) << 8) | s >> 56 *) - emit (Psllil(X1, X s, coqint_of_camlint 56l)); +(*emit (Psllil(X1, X s, coqint_of_camlint 56l)); List.iter (fun (n1, n2) -> emit (Psrlil(X31, X s, coqint_of_camlint n1)); @@ -393,6 +408,7 @@ let expand_bswap64 d s = [(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)) +*) (* Handling of compiler-inlined builtins *) @@ -401,13 +417,13 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () - | "__builtin_fence", [], _ -> +(*| "__builtin_fence", [], _ -> emit Pfence - (* Vararg stuff *) +*)(* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a (* Byte swaps *) - | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> +(*| "__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 @@ -468,7 +484,7 @@ let expand_builtin_inline name args res = (fun rl -> emit (Pmulw (rl, X a, X b)); emit (Pmulhuw (rh, X a, X b))) - +*) (* Catch-all *) | _ -> raise (Error ("unrecognized builtin " ^ name)) @@ -479,20 +495,20 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (X30, X2)); + emit (Pmv (GPR32, GPR12)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg full_sz)); - expand_storeind_ptr X30 X2 ofs; + expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg full_sz)); + expand_storeind_ptr GPR32 GPR12 ofs; let va_ofs = Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin - expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg sz)); - expand_storeind_ptr X30 X2 ofs; + expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg sz)); + expand_storeind_ptr GPR32 GPR12 ofs; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> @@ -502,9 +518,9 @@ let expand_instruction instr = let n = arguments_size sg in if n >= 8 then 0 else align 16 ((8 - n) * wordsize) end else 0 in - expand_addptrofs X2 X2 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) - | Pseqw(rd, rs1, rs2) -> +(*| Pseqw(rd, rs1, rs2) -> (* emulate based on the fact that x == 0 iff x assert false end - | _ -> +*)| _ -> emit instr (* NOTE: Dwarf register maps for RV32G are not yet specified officially. This is just a placeholder. *) let int_reg_to_dwarf = function - | X1 -> 1 | X2 -> 2 | X3 -> 3 - | X4 -> 4 | X5 -> 5 | X6 -> 6 | X7 -> 7 - | X8 -> 8 | X9 -> 9 | X10 -> 10 | X11 -> 11 - | X12 -> 12 | X13 -> 13 | X14 -> 14 | X15 -> 15 - | X16 -> 16 | X17 -> 17 | X18 -> 18 | X19 -> 19 - | X20 -> 20 | X21 -> 21 | X22 -> 22 | X23 -> 23 - | X24 -> 24 | X25 -> 25 | X26 -> 26 | X27 -> 27 - | X28 -> 28 | X29 -> 29 | X30 -> 30 | X31 -> 31 - -let float_reg_to_dwarf = function - | F0 -> 32 | F1 -> 33 | F2 -> 34 | F3 -> 35 - | F4 -> 36 | F5 -> 37 | F6 -> 38 | F7 -> 39 - | F8 -> 40 | F9 -> 41 | F10 -> 42 | F11 -> 43 - | F12 -> 44 | F13 -> 45 | F14 -> 46 | F15 -> 47 - | F16 -> 48 | F17 -> 49 | F18 -> 50 | F19 -> 51 - | F20 -> 52 | F21 -> 53 | F22 -> 54 | F23 -> 55 - | F24 -> 56 | F25 -> 57 | F26 -> 58 | F27 -> 59 - | F28 -> 60 | F29 -> 61 | F30 -> 62 | F31 -> 63 + | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 + | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 + | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 + | GPR15 -> 16 | GPR16 -> 17 | GPR17 -> 18 | GPR18 -> 19 | GPR19 -> 20 + | GPR20 -> 21 | GPR21 -> 22 | GPR22 -> 23 | GPR23 -> 24 | GPR24 -> 25 + | GPR25 -> 26 | GPR26 -> 27 | GPR27 -> 28 | GPR28 -> 29 | GPR29 -> 30 + | GPR30 -> 31 | GPR31 -> 32 | GPR32 -> 33 | GPR33 -> 34 | GPR34 -> 35 + | GPR35 -> 36 | GPR36 -> 37 | GPR37 -> 38 | GPR38 -> 39 | GPR39 -> 40 + | GPR40 -> 41 | GPR41 -> 42 | GPR42 -> 43 | GPR43 -> 44 | GPR44 -> 45 + | GPR45 -> 46 | GPR46 -> 47 | GPR47 -> 48 | GPR48 -> 49 | GPR49 -> 50 + | GPR50 -> 51 | GPR51 -> 52 | GPR52 -> 53 | GPR53 -> 54 | GPR54 -> 55 + | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 + | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 let preg_to_dwarf = function | IR r -> int_reg_to_dwarf r - | FR r -> float_reg_to_dwarf r + | FR r -> int_reg_to_dwarf r + | RA -> 65 (* FIXME - No idea *) | _ -> assert false let expand_function id fn = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 696bc87f..3d348655 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -40,66 +40,41 @@ module Target : TARGET = let print_label oc lbl = label oc (transl_label lbl) - let use_abi_name = false - - let int_reg_num_name = function - | X1 -> "x1" | X2 -> "x2" | X3 -> "x3" - | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7" - | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11" - | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15" - | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19" - | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23" - | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27" - | X28 -> "x28" | X29 -> "x29" | X30 -> "x30" | X31 -> "x31" - - let int_reg_abi_name = function - | X1 -> "ra" | X2 -> "sp" | X3 -> "gp" - | X4 -> "tp" | X5 -> "t0" | X6 -> "t1" | X7 -> "t2" - | X8 -> "s0" | X9 -> "s1" | X10 -> "a0" | X11 -> "a1" - | X12 -> "a2" | X13 -> "a3" | X14 -> "a4" | X15 -> "a5" - | X16 -> "a6" | X17 -> "a7" | X18 -> "s2" | X19 -> "s3" - | X20 -> "s4" | X21 -> "s5" | X22 -> "s6" | X23 -> "s7" - | X24 -> "s8" | X25 -> "s9" | X26 -> "s10" | X27 -> "s11" - | X28 -> "t3" | X29 -> "t4" | X30 -> "t5" | X31 -> "t6" - - let float_reg_num_name = function - | F0 -> "f0" | F1 -> "f1" | F2 -> "f2" | F3 -> "f3" - | F4 -> "f4" | F5 -> "f5" | F6 -> "f6" | F7 -> "f7" - | F8 -> "f8" | F9 -> "f9" | F10 -> "f10" | F11 -> "f11" - | F12 -> "f12" | F13 -> "f13" | F14 -> "f14" | F15 -> "f15" - | F16 -> "f16" | F17 -> "f17" | F18 -> "f18" | F19 -> "f19" - | F20 -> "f20" | F21 -> "f21" | F22 -> "f22" | F23 -> "f23" - | F24 -> "f24" | F25 -> "f25" | F26 -> "f26" | F27 -> "f27" - | F28 -> "f28" | F29 -> "f29" | F30 -> "f30" | F31 -> "f31" - - let float_reg_abi_name = function - | F0 -> "ft0" | F1 -> "ft1" | F2 -> "ft2" | F3 -> "ft3" - | F4 -> "ft4" | F5 -> "ft5" | F6 -> "ft6" | F7 -> "ft7" - | F8 -> "fs0" | F9 -> "fs1" | F10 -> "fa0" | F11 -> "fa1" - | F12 -> "fa2" | F13 -> "fa3" | F14 -> "fa4" | F15 -> "fa5" - | F16 -> "fa6" | F17 -> "fa7" | F18 -> "fs2" | F19 -> "fs3" - | F20 -> "fs4" | F21 -> "fs5" | F22 -> "fs6" | F23 -> "fs7" - | F24 -> "fs8" | F25 -> "fs9" | F26 ->"fs10" | F27 -> "fs11" - | F28 -> "ft3" | F29 -> "ft4" | F30 -> "ft5" | F31 -> "ft6" - - let int_reg_name = if use_abi_name then int_reg_abi_name else int_reg_num_name - let float_reg_name = if use_abi_name then float_reg_abi_name else float_reg_num_name + let int_reg_name = function + | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" + | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" + | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" + | GPR12 -> "$r12" | GPR13 -> "$r13" | GPR14 -> "$r14" | GPR15 -> "$r15" + | GPR16 -> "$r16" | GPR17 -> "$r17" | GPR18 -> "$r18" | GPR19 -> "$r19" + | GPR20 -> "$r20" | GPR21 -> "$r21" | GPR22 -> "$r22" | GPR23 -> "$r23" + | GPR24 -> "$r24" | GPR25 -> "$r25" | GPR26 -> "$r26" | GPR27 -> "$r27" + | GPR28 -> "$r28" | GPR29 -> "$r29" | GPR30 -> "$r30" | GPR31 -> "$r31" + | GPR32 -> "$r32" | GPR33 -> "$r33" | GPR34 -> "$r34" | GPR35 -> "$r35" + | GPR36 -> "$r36" | GPR37 -> "$r37" | GPR38 -> "$r38" | GPR39 -> "$r39" + | GPR40 -> "$r40" | GPR41 -> "$r41" | GPR42 -> "$r42" | GPR43 -> "$r43" + | GPR44 -> "$r44" | GPR45 -> "$r45" | GPR46 -> "$r46" | GPR47 -> "$r47" + | GPR48 -> "$r48" | GPR49 -> "$r49" | GPR50 -> "$r50" | GPR51 -> "$r51" + | GPR52 -> "$r52" | GPR53 -> "$r53" | GPR54 -> "$r54" | GPR55 -> "$r55" + | GPR56 -> "$r56" | GPR57 -> "$r57" | GPR58 -> "$r58" | GPR59 -> "$r59" + | GPR60 -> "$r60" | GPR61 -> "$r61" | GPR62 -> "$r62" | GPR63 -> "$r63" let ireg oc r = output_string oc (int_reg_name r) - let freg oc r = output_string oc (float_reg_name r) + let ireg0 = ireg +(* let ireg0 oc = function - | X0 -> output_string oc "x0" - | X r -> ireg oc r - + | GPR r -> ireg oc r +*) let preg oc = function | IR r -> ireg oc r - | FR r -> freg oc r + | FR r -> ireg oc r + | RA -> output_string oc "$ra" | _ -> assert false let preg_annot = function | IR r -> int_reg_name r - | FR r -> float_reg_name r + | FR r -> int_reg_name r + | RA -> "$ra" | _ -> assert false (* Names of sections *) @@ -152,7 +127,7 @@ module Target : TARGET = (* Generate code to load the address of id + ofs in register r *) - let loadsymbol oc r id ofs = + (*let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); fprintf oc " la %a, %s\n" ireg r (extern_atom id) @@ -162,7 +137,7 @@ module Target : TARGET = fprintf oc " addi %a, %a, %%lo(%a)\n" ireg r ireg r symbol_offset (id, ofs) end - + *) (* Emit .file / .loc debugging directives *) let print_file_line oc file line = @@ -175,9 +150,9 @@ module Target : TARGET = (* Add "w" suffix to 32-bit instructions if we are in 64-bit mode *) - let w oc = + (*let w oc = if Archi.ptr64 then output_string oc "w" - + *) (* Offset part of a load or store *) let offset oc = function @@ -186,11 +161,17 @@ module Target : TARGET = (* Printing of instructions *) let print_instruction oc = function + | Pret -> + fprintf oc " ret\n;;\n" + | Pget (rd, rs) -> + fprintf oc " get %a = %a\n;;\n" ireg rd preg rs + | Pset (rd, rs) -> + fprintf oc " set %a = %a\n;;\n" preg rd ireg rs | Pmv(rd, rs) -> - fprintf oc " mv %a, %a\n" ireg rd ireg rs + fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs (* 32-bit integer register-immediate instructions *) - | Paddiw (rd, rs, imm) -> + (*| Paddiw (rd, rs, imm) -> fprintf oc " addi%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm | Psltiw (rd, rs, imm) -> fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint imm @@ -251,10 +232,10 @@ module Target : TARGET = | Psraw(rd, rs1, rs2) -> fprintf oc " sra%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 - (* 64-bit integer register-immediate instructions *) + *)(* 64-bit integer register-immediate instructions *) | Paddil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " addi %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm - | Psltil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg0 rs coqint64 imm + (*| Psltil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm | Psltiul (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm @@ -272,11 +253,15 @@ module Target : TARGET = fprintf oc " srai %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm | Pluil (rd, imm) -> assert Archi.ptr64; fprintf oc " lui %a, %a\n" ireg rd coqint64 imm - + *) + | Pmake (rd, imm) -> + fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm + | Pmakel (rd, imm) -> + fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm (* 64-bit integer register-register instructions *) | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " add %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 - | Psubl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg0 rs1 ireg0 rs2 + (*| Psubl(rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " sub %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 | Pmull(rd, rs1, rs2) -> assert Archi.ptr64; @@ -366,21 +351,21 @@ module Target : TARGET = fprintf oc " lhu %a, %a(%a)\n" ireg rd offset ofs ireg ra | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) -> fprintf oc " lw %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Pld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a, %a(%a)\n" ireg rd offset ofs ireg ra + *)| Pld(rd, ra, ofs) (*| Pld_a(rd, ra, ofs)*) -> assert Archi.ptr64; + fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Psb(rd, ra, ofs) -> + (*| Psb(rd, ra, ofs) -> fprintf oc " sb %a, %a(%a)\n" ireg rd offset ofs ireg ra | Psh(rd, ra, ofs) -> fprintf oc " sh %a, %a(%a)\n" ireg rd offset ofs ireg ra | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) -> fprintf oc " sw %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a, %a(%a)\n" ireg rd offset ofs ireg ra + *)| Psd(rd, ra, ofs) (*| Psd_a(rd, ra, ofs)*) -> assert Archi.ptr64; + fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd (* Synchronization *) - | Pfence -> + (*| Pfence -> fprintf oc " fence\n" (* floating point register move. @@ -522,17 +507,17 @@ module Target : TARGET = fprintf oc " fcvt.s.d %a, %a\n" freg fd freg fs (* Pseudo-instructions expanded in Asmexpand *) - | Pallocframe(sz, ofs) -> + *)| Pallocframe(sz, ofs) -> assert false | Pfreeframe(sz, ofs) -> assert false - | Pseqw _ | Psnew _ | Pseql _ | Psnel _ | Pcvtl2w _ | Pcvtw2l _ -> + (*| Pseqw _ | Psnew _ | Pseql _ | Psnel _ | Pcvtl2w _ | Pcvtw2l _ -> assert false (* Pseudo-instructions that remain *) - | Plabel lbl -> + *)| Plabel lbl -> fprintf oc "%a:\n" print_label lbl - | Ploadsymbol(rd, id, ofs) -> + (*| Ploadsymbol(rd, id, ofs) -> loadsymbol oc rd id ofs | Ploadsymbol_high(rd, id, ofs) -> fprintf oc " lui %a, %%hi(%a)\n" ireg rd symbol_offset (id, ofs) @@ -563,7 +548,7 @@ module Target : TARGET = fprintf oc " jr x5\n"; jumptables := (lbl, tbl) :: !jumptables; fprintf oc "%s end pseudoinstr btbl\n" comment - | Pbuiltin(ef, args, res) -> + *)| Pbuiltin(ef, args, res) -> begin match ef with | EF_annot(kind,txt, targs) -> let annot = @@ -635,7 +620,7 @@ module Target : TARGET = let address = if Archi.ptr64 then ".quad" else ".long" let print_prologue oc = - fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); + (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) if !Clflags.option_g then begin section oc Section_text; end -- cgit From 348aa9268bb3f7f2fe4357586a4e1d3181e0c9b3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 16 Mar 2018 15:06:28 +0100 Subject: MPPA - code cleaning --- mppa_k1c/Asm.v | 45 ++++++++++++++++----------------------------- mppa_k1c/Asmexpand.ml | 2 +- mppa_k1c/Asmgen.v | 45 ++++----------------------------------------- mppa_k1c/Asmgenproof.v | 16 +++++++++------- mppa_k1c/Asmgenproof1.v | 18 +++++++++--------- mppa_k1c/Conventions1.v | 9 ++++++--- mppa_k1c/Machregs.v | 35 ++++++++++++++++++----------------- mppa_k1c/TargetPrinter.ml | 7 ++----- 8 files changed, 65 insertions(+), 112 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 9c85dbbd..e7dfdc52 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -15,7 +15,7 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for RISC-V assembly language. *) +(** Abstract syntax and semantics for K1c assembly language. *) Require Import Coqlib. Require Import Maps. @@ -38,22 +38,22 @@ Require Import Conventions. Inductive gpreg: Type := | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg - | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg - | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg - | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg - | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg - | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg - | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg - | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg - | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg - | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg - | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. Definition ireg := gpreg. (* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) -Inductive ireg0: Type := +Inductive ireg0: Type := | GPR: gpreg -> ireg0. Coercion GPR: gpreg >-> ireg0. @@ -138,7 +138,7 @@ Inductive instruction : Type := | Pget (rd: ireg) (rs: preg) (**r get system register *) | Pset (rd: preg) (rs: ireg) (**r set system register *) | Pret (**r return *) - + | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) @@ -175,7 +175,7 @@ Inductive instruction : Type := | Psraw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) (** 64-bit integer register-immediate instructions *) -*) | Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) (* +*)| Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) (* | Psltil (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than immediate *) | Psltiul (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than unsigned immediate *) | Pandil (rd: ireg) (rs: ireg0) (imm: int64) (**r and immediate *) @@ -339,15 +339,14 @@ Inductive instruction : Type := | 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 *) +(*| Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) (* -*) + -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) (** The pseudo-instructions are the following: @@ -444,23 +443,11 @@ Definition getw (rs: regset) (r: ireg0) : val := match r with | GPR r => rs r end. -(* - match r with - | X0 => Vint Int.zero - | X r => rs r - end. -*) Definition getl (rs: regset) (r: ireg0) : val := match r with | GPR r => rs r end. -(* - match r with - | X0 => Vlong Int64.zero - | X r => rs r - end. -*) Notation "a # b" := (a b) (at level 1, only parsing) : asm. Notation "a ## b" := (getw a b) (at level 1) : asm. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index fea71f61..f21ad2eb 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -604,7 +604,7 @@ let int_reg_to_dwarf = function let preg_to_dwarf = function | IR r -> int_reg_to_dwarf r | FR r -> int_reg_to_dwarf r - | RA -> 65 (* FIXME - No idea *) + | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) | _ -> assert false let expand_function id fn = diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index efcafda2..2d2c2e3b 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -68,7 +68,7 @@ Definition make_immed64 (val: int64) := Imm64_single val. Definition load_hilo32 (r: ireg) (hi lo: int) k := if Int.eq lo Int.zero then Pluiw r hi :: k else Pluiw r hi :: Paddiw r r lo :: k. -*) +*) Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => Pmake r imm :: k @@ -88,8 +88,7 @@ Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. -*) -(* + Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k else Pluil r hi :: Paddil r r lo :: k. @@ -490,7 +489,7 @@ Definition transl_op Psraiw GPR31 rs (Int.repr 31) :: Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) :: Paddw GPR31 rs GPR31 :: - Psraiw rd GPR31 n :: k) + Psraiw rd GPR31 n :: k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => @@ -579,7 +578,7 @@ Definition transl_op Psrail GPR31 rs (Int.repr 63) :: Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: Paddl GPR31 rs GPR31 :: - Psrail rd GPR31 n :: k) + Psrail rd GPR31 n :: k) | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; @@ -802,37 +801,10 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) (** Function epilogue *) -(* -Definition store_ra (base: ireg) (ofs: ptrofs) (k: code) := - indexed_memory_access (Psd GPR8) base ofs (Pget GPR8 RA :: k) - . -*) - -(* -Definition make_ra (base: ireg) (ofs: ptrofs) (k: code) := - Pset RA GPR8 - :: (indexed_memory_access (Pld GPR8) base ofs k) (* FIXME - not sure about GPR8 *) - . -*) - -(* -Definition make_epilogue (f: Mach.function) (k: code) := - Pset RA GPR8 :: (indexed_memory_access (Pld GPR8) SP f.(fn_retaddr_ofs) (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k)) - (* make_ra SP f.(fn_retaddr_ofs) - (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k) *) - . -*) - Definition make_epilogue (f: Mach.function) (k: code) := loadind_ptr SP f.(fn_retaddr_ofs) GPR8 (Pset RA GPR8 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). -(* -Definition make_epilogue (f: Mach.function) (k: code) := - loadind_ptr SP f.(fn_retaddr_ofs) RA - (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). -*) - (** Translation of a Mach instruction. *) Definition transl_instr (f: Mach.function) (i: Mach.instruction) @@ -926,15 +898,6 @@ Definition transl_function (f: Mach.function) := Pget GPR8 RA :: storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). -(* -Definition transl_function (f: Mach.function) := - do c <- transl_code' f f.(Mach.fn_code) true; - OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - indexed_memory_access (Psd GPR8) SP f.(fn_retaddr_ofs) (Pget GPR8 RA :: c))). - (* store_ra SP f.(fn_retaddr_ofs) c)). *) -*) - Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index a5ea3bb9..45531e00 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -119,6 +119,7 @@ Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k). Proof. intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) Qed. Hint Resolve loadimm32_label: labels. (* @@ -137,6 +138,7 @@ Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). Proof. intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) Qed. Hint Resolve loadimm64_label: labels. @@ -658,7 +660,7 @@ Proof. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. inversion TR. -(* +(* intros [rs' [P [Q R]]]. exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. @@ -689,7 +691,7 @@ Proof. intros [v' [C D]]. (* Opaque loadind. *) left; eapply exec_straight_steps; eauto; intros. monadInv TR. -(* +(* destruct ep. (* X30 contains parent *) exploit loadind_correct. eexact EQ. @@ -752,7 +754,7 @@ Local Transparent destroyed_by_op. assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. exploit Mem.storev_extends; eauto. intros [m2' [C D]]. left; eapply exec_straight_steps; eauto. - intros. simpl in TR. + intros. simpl in TR. inversion TR. (*exploit transl_store_correct; eauto. intros [rs2 [P Q]]. exists rs2; split. eauto. @@ -971,8 +973,8 @@ Local Transparent destroyed_by_op. assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } rewrite H3. rewrite H4. (* change (rs' GPR8) with (rs0 RA). *) - rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. congruence. congruence. intros (rs3 & U & V). assert (EXEC_PROLOGUE: @@ -985,7 +987,7 @@ Local Transparent destroyed_by_op. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. reflexivity. eapply exec_straight_trans. - - eexact U'. + - eexact U'. - eexact U. } exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. intros (ofs' & X & Y). @@ -1003,7 +1005,7 @@ Local Transparent destroyed_at_function_entry. unfold sp; congruence. intros. - assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } rewrite V. assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index f83275a1..6957ab87 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -175,7 +175,7 @@ Proof. Qed. (** 64-bit integer constants and arithmetic *) - + Lemma load_hilo64_correct: forall rd hi lo k rs m, exists rs', @@ -194,7 +194,7 @@ Proof. split. Simpl. intros; Simpl. Qed. - + Lemma loadimm64_correct: forall rd n k rs m, exists rs', @@ -381,7 +381,7 @@ Qed. Remark branch_on_GPR31: forall normal lbl (rs: regset) m b, - rs#GPR31 = Val.of_bool (eqb normal b) -> + rs#GPR31 = Val.of_bool (eqb normal b) -> exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 X0 lbl) rs m = eval_branch fn lbl rs m (Some b). Proof. @@ -1072,12 +1072,12 @@ Opaque Int.eq. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. - + - (* addlimm *) exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. - + - (* andimm *) exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). @@ -1251,7 +1251,7 @@ Proof. - simpl. rewrite H. auto. - Simpl. - Simpl. -- intros. rewrite H. Simpl. +- intros. rewrite H. Simpl. Qed. Lemma Pset_correct: @@ -1431,14 +1431,14 @@ Proof. exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). unfold make_epilogue. rewrite chunk_of_Tptr in *. - + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - congruence. - intros (rs1 & A1 & B1 & C1). assert (agree ms (Vptr stk soff) rs1) as AG1. - + destruct AG. + + destruct AG. apply mkagree; auto. rewrite C1; discriminate || auto. intro. rewrite C1; auto; destruct r; simpl; try discriminate. @@ -1457,7 +1457,7 @@ Proof. apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. eapply parent_sp_def; eauto. split. auto. - split. Simpl. rewrite B2. auto. + split. Simpl. rewrite B2. auto. split. Simpl. intros. Simpl. rewrite C2; auto. diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 6bb616c8..68beb560 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -32,7 +32,7 @@ Require Import AST Machregs Locations. of callee- and caller-save registers. *) -Definition is_callee_save (r: mreg): bool := +Definition is_callee_save (r: mreg) : bool := match r with | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 => true @@ -90,7 +90,7 @@ Definition is_float_reg (r: mreg) := false. with one integer result. *) Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with + match s.(sig_res) with | None => One R0 | Some (Tint | Tany32) => One R0 | Some (Tfloat | Tsingle | Tany64) => One R0 @@ -334,7 +334,10 @@ Proof. cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). unfold OK. eauto. - induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. - red; simpl; tauto. - destruct ty1. + (* int *) apply A; auto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. + - red; simpl; tauto. + - destruct ty1. ++ (* int *) apply A; auto. + (* float *) apply A; auto. + (* long *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ee7d91da..ce86a06f 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -85,18 +85,19 @@ Module IndexedMreg <: INDEXED_TYPE. Definition eq := mreg_eq. Definition index (r: mreg): positive := match r with - R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 - | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 - | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 - | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 - | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 - | R30 => 31 | R32 => 33 | R33 => 34 | R34 => 35 - | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 - | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 - | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 - | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 - | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 - | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 end. + | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 + | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 + | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 + | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 + | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 + | R30 => 31 | R32 => 33 | R33 => 34 | R34 => 35 + | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 + | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 + | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 + | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 + | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 + | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 + end. Lemma index_inj: forall r1 r2, index r1 = index r2 -> r1 = r2. @@ -112,8 +113,8 @@ Definition is_stack_reg (r: mreg) : bool := false. Local Open Scope string_scope. Definition register_names := - ("R0", R0) :: ("R1", R1) :: ("R2", R2) :: ("R3", R3) :: ("R4", R4) - :: ("R5", R5) :: ("R6", R6) :: ("R7", R7) :: ("R9", R9) + ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) + :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R9" , R9) :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) @@ -141,8 +142,8 @@ Definition destroyed_by_op (op: operation): list mreg := nil. | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle => F6 :: nil | _ => nil - end. *) - + end. +*) Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. @@ -166,7 +167,7 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob - (* | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil *) +(*| EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil *) | _ => nil end. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3d348655..e256661a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -61,10 +61,7 @@ module Target : TARGET = let ireg oc r = output_string oc (int_reg_name r) let ireg0 = ireg -(* - let ireg0 oc = function - | GPR r -> ireg oc r -*) + let preg oc = function | IR r -> ireg oc r | FR r -> ireg oc r @@ -620,7 +617,7 @@ module Target : TARGET = let address = if Archi.ptr64 then ".quad" else ".long" let print_prologue oc = - (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) + (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) if !Clflags.option_g then begin section oc Section_text; end -- cgit From fab4d5289e9a6fc7b5a285f2181fccca99ac0a86 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 19 Mar 2018 10:44:33 +0100 Subject: Replaced ireg0 by ireg --- mppa_k1c/Asm.v | 170 +++++++++++++++++++++++----------------------- mppa_k1c/Asmgen.v | 24 +++---- mppa_k1c/Asmgenproof1.v | 4 +- mppa_k1c/TargetPrinter.ml | 146 +++++++++++++++++++-------------------- 4 files changed, 173 insertions(+), 171 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e7dfdc52..4693975b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -52,11 +52,13 @@ Inductive gpreg: Type := Definition ireg := gpreg. +(* (* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) Inductive ireg0: Type := | GPR: gpreg -> ireg0. Coercion GPR: gpreg >-> ireg0. +*) Definition freg := gpreg. @@ -142,74 +144,74 @@ Inductive instruction : Type := | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) -(*| Paddiw (rd: ireg) (rs: ireg0) (imm: int) (**r add immediate *) - | Psltiw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than immediate *) - | Psltiuw (rd: ireg) (rs: ireg0) (imm: int) (**r set-less-than unsigned immediate *) - | Pandiw (rd: ireg) (rs: ireg0) (imm: int) (**r and immediate *) - | Poriw (rd: ireg) (rs: ireg0) (imm: int) (**r or immediate *) - | Pxoriw (rd: ireg) (rs: ireg0) (imm: int) (**r xor immediate *) - | Pslliw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) - | Psrliw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) - | Psraiw (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) +(*| Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) + | Psltiw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than immediate *) + | Psltiuw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than unsigned immediate *) + | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) + | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or immediate *) + | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor immediate *) + | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift-left-logical immediate *) + | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-logical immediate *) + | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-arith immediate *) | Pluiw (rd: ireg) (imm: int) (**r load upper-immediate *) (** 32-bit integer register-register instructions *) - | Paddw (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) - | Psubw (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) - - | Pmulw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) - | Pmulhw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high signed *) - | Pmulhuw (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high unsigned *) - | Pdivw (rd: ireg) (rs1 rs2: ireg0) (**r integer division *) - | Pdivuw (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer division *) - | Premw (rd: ireg) (rs1 rs2: ireg0) (**r integer remainder *) - | Premuw (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer remainder *) - | Psltw (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than *) - | Psltuw (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than unsigned *) - | Pseqw (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 == rs2] (pseudo) *) - | Psnew (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 != rs2] (pseudo) *) - | Pandw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise and *) - | Porw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise or *) - | Pxorw (rd: ireg) (rs1 rs2: ireg0) (**r bitwise xor *) - | Psllw (rd: ireg) (rs1 rs2: ireg0) (**r shift-left-logical *) - | Psrlw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-logical *) - | Psraw (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) + | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) + + | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply low *) + | Pmulhw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high signed *) + | Pmulhuw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high unsigned *) + | Pdivw (rd: ireg) (rs1 rs2: ireg) (**r integer division *) + | Pdivuw (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer division *) + | Premw (rd: ireg) (rs1 rs2: ireg) (**r integer remainder *) + | Premuw (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer remainder *) + | Psltw (rd: ireg) (rs1 rs2: ireg) (**r set-less-than *) + | Psltuw (rd: ireg) (rs1 rs2: ireg) (**r set-less-than unsigned *) + | Pseqw (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 == rs2] (pseudo) *) + | Psnew (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 != rs2] (pseudo) *) + | Pandw (rd: ireg) (rs1 rs2: ireg) (**r bitwise and *) + | Porw (rd: ireg) (rs1 rs2: ireg) (**r bitwise or *) + | Pxorw (rd: ireg) (rs1 rs2: ireg) (**r bitwise xor *) + | Psllw (rd: ireg) (rs1 rs2: ireg) (**r shift-left-logical *) + | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift-right-logical *) + | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift-right-arith *) (** 64-bit integer register-immediate instructions *) -*)| Paddil (rd: ireg) (rs: ireg0) (imm: int64) (**r add immediate *) (* - | Psltil (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than immediate *) - | Psltiul (rd: ireg) (rs: ireg0) (imm: int64) (**r set-less-than unsigned immediate *) - | Pandil (rd: ireg) (rs: ireg0) (imm: int64) (**r and immediate *) - | Poril (rd: ireg) (rs: ireg0) (imm: int64) (**r or immediate *) - | Pxoril (rd: ireg) (rs: ireg0) (imm: int64) (**r xor immediate *) - | Psllil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-left-logical immediate *) - | Psrlil (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-logical immediate *) - | Psrail (rd: ireg) (rs: ireg0) (imm: int) (**r shift-right-arith immediate *) +*)| Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) (* + | Psltil (rd: ireg) (rs: ireg) (imm: int64) (**r set-less-than immediate *) + | Psltiul (rd: ireg) (rs: ireg) (imm: int64) (**r set-less-than unsigned immediate *) + | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) + | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or immediate *) + | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor immediate *) + | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift-left-logical immediate *) + | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-logical immediate *) + | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-arith immediate *) | Pluil (rd: ireg) (imm: int64) (**r FIXME - remove it ; load upper-immediate *) *)| Pmake (rd: ireg) (imm: int) (**r load immediate *) | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) (** 64-bit integer register-register instructions *) - | Paddl (rd: ireg) (rs1 rs2: ireg0) (**r integer addition *) (* - | Psubl (rd: ireg) (rs1 rs2: ireg0) (**r integer subtraction *) - - | Pmull (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply low *) - | Pmulhl (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high signed *) - | Pmulhul (rd: ireg) (rs1 rs2: ireg0) (**r integer multiply high unsigned *) - | Pdivl (rd: ireg) (rs1 rs2: ireg0) (**r integer division *) - | Pdivul (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer division *) - | Preml (rd: ireg) (rs1 rs2: ireg0) (**r integer remainder *) - | Premul (rd: ireg) (rs1 rs2: ireg0) (**r unsigned integer remainder *) - | Psltl (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than *) - | Psltul (rd: ireg) (rs1 rs2: ireg0) (**r set-less-than unsigned *) - | Pseql (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 == rs2] (pseudo) *) - | Psnel (rd: ireg) (rs1 rs2: ireg0) (**r [rd <- rs1 != rs2] (pseudo) *) - | Pandl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise and *) - | Porl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise or *) - | Pxorl (rd: ireg) (rs1 rs2: ireg0) (**r bitwise xor *) - | Pslll (rd: ireg) (rs1 rs2: ireg0) (**r shift-left-logical *) - | Psrll (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-logical *) - | Psral (rd: ireg) (rs1 rs2: ireg0) (**r shift-right-arith *) - - | Pcvtl2w (rd: ireg) (rs: ireg0) (**r int64->int32 (pseudo) *) + | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) (* + | Psubl (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) + + | Pmull (rd: ireg) (rs1 rs2: ireg) (**r integer multiply low *) + | Pmulhl (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high signed *) + | Pmulhul (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high unsigned *) + | Pdivl (rd: ireg) (rs1 rs2: ireg) (**r integer division *) + | Pdivul (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer division *) + | Preml (rd: ireg) (rs1 rs2: ireg) (**r integer remainder *) + | Premul (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer remainder *) + | Psltl (rd: ireg) (rs1 rs2: ireg) (**r set-less-than *) + | Psltul (rd: ireg) (rs1 rs2: ireg) (**r set-less-than unsigned *) + | Pseql (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 == rs2] (pseudo) *) + | Psnel (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 != rs2] (pseudo) *) + | Pandl (rd: ireg) (rs1 rs2: ireg) (**r bitwise and *) + | Porl (rd: ireg) (rs1 rs2: ireg) (**r bitwise or *) + | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r bitwise xor *) + | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift-left-logical *) + | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift-right-logical *) + | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift-right-arith *) + + | Pcvtl2w (rd: ireg) (rs: ireg) (**r int64->int32 (pseudo) *) | Pcvtw2l (r: ireg) (**r int32 signed -> int64 (pseudo) *) (* Unconditional jumps. Links are always to X1/RA. *) @@ -220,20 +222,20 @@ Inductive instruction : Type := | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) (* Conditional branches, 32-bit comparisons *) - | Pbeqw (rs1 rs2: ireg0) (l: label) (**r branch-if-equal *) - | Pbnew (rs1 rs2: ireg0) (l: label) (**r branch-if-not-equal signed *) - | Pbltw (rs1 rs2: ireg0) (l: label) (**r branch-if-less signed *) - | Pbltuw (rs1 rs2: ireg0) (l: label) (**r branch-if-less unsigned *) - | Pbgew (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal signed *) - | Pbgeuw (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal unsigned *) + | Pbeqw (rs1 rs2: ireg) (l: label) (**r branch-if-equal *) + | Pbnew (rs1 rs2: ireg) (l: label) (**r branch-if-not-equal signed *) + | Pbltw (rs1 rs2: ireg) (l: label) (**r branch-if-less signed *) + | Pbltuw (rs1 rs2: ireg) (l: label) (**r branch-if-less unsigned *) + | Pbgew (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal signed *) + | Pbgeuw (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal unsigned *) (* Conditional branches, 64-bit comparisons *) - | Pbeql (rs1 rs2: ireg0) (l: label) (**r branch-if-equal *) - | Pbnel (rs1 rs2: ireg0) (l: label) (**r branch-if-not-equal signed *) - | Pbltl (rs1 rs2: ireg0) (l: label) (**r branch-if-less signed *) - | Pbltul (rs1 rs2: ireg0) (l: label) (**r branch-if-less unsigned *) - | Pbgel (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal signed *) - | Pbgeul (rs1 rs2: ireg0) (l: label) (**r branch-if-greater-or-equal unsigned *) + | Pbeql (rs1 rs2: ireg) (l: label) (**r branch-if-equal *) + | Pbnel (rs1 rs2: ireg) (l: label) (**r branch-if-not-equal signed *) + | Pbltl (rs1 rs2: ireg) (l: label) (**r branch-if-less signed *) + | Pbltul (rs1 rs2: ireg) (l: label) (**r branch-if-less unsigned *) + | Pbgel (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal signed *) + | Pbgeul (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal unsigned *) (* Loads and stores *) | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int8 *) @@ -287,13 +289,13 @@ Inductive instruction : Type := | Pfcvtws (rd: ireg) (rs: freg) (**r float32 -> int32 conversion *) | Pfcvtwus (rd: ireg) (rs: freg) (**r float32 -> unsigned int32 conversion *) - | Pfcvtsw (rd: freg) (rs: ireg0) (**r int32 -> float32 conversion *) - | Pfcvtswu (rd: freg) (rs: ireg0) (**r unsigned int32 -> float32 conversion *) + | Pfcvtsw (rd: freg) (rs: ireg) (**r int32 -> float32 conversion *) + | Pfcvtswu (rd: freg) (rs: ireg) (**r unsigned int32 -> float32 conversion *) | Pfcvtls (rd: ireg) (rs: freg) (**r float32 -> int64 conversion *) | Pfcvtlus (rd: ireg) (rs: freg) (**r float32 -> unsigned int64 conversion *) - | Pfcvtsl (rd: freg) (rs: ireg0) (**r int64 -> float32 conversion *) - | Pfcvtslu (rd: freg) (rs: ireg0) (**r unsigned int 64-> float32 conversion *) + | Pfcvtsl (rd: freg) (rs: ireg) (**r int64 -> float32 conversion *) + | Pfcvtslu (rd: freg) (rs: ireg) (**r unsigned int 64-> float32 conversion *) (* 64-bit (double-precision) floating point *) | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) @@ -324,13 +326,13 @@ Inductive instruction : Type := | Pfcvtwd (rd: ireg) (rs: freg) (**r float -> int32 conversion *) | Pfcvtwud (rd: ireg) (rs: freg) (**r float -> unsigned int32 conversion *) - | Pfcvtdw (rd: freg) (rs: ireg0) (**r int32 -> float conversion *) - | Pfcvtdwu (rd: freg) (rs: ireg0) (**r unsigned int32 -> float conversion *) + | Pfcvtdw (rd: freg) (rs: ireg) (**r int32 -> float conversion *) + | Pfcvtdwu (rd: freg) (rs: ireg) (**r unsigned int32 -> float conversion *) | Pfcvtld (rd: ireg) (rs: freg) (**r float -> int64 conversion *) | Pfcvtlud (rd: ireg) (rs: freg) (**r float -> unsigned int64 conversion *) - | Pfcvtdl (rd: freg) (rs: ireg0) (**r int64 -> float conversion *) - | Pfcvtdlu (rd: freg) (rs: ireg0) (**r unsigned int64 -> float conversion *) + | Pfcvtdl (rd: freg) (rs: ireg) (**r int64 -> float conversion *) + | Pfcvtdlu (rd: freg) (rs: ireg) (**r unsigned int64 -> float conversion *) | Pfcvtds (rd: freg) (rs: freg) (**r float32 -> float *) | Pfcvtsd (rd: freg) (rs: freg) (**r float -> float32 *) @@ -439,14 +441,14 @@ Definition program := AST.program fundef unit. Definition regset := Pregmap.t val. Definition genv := Genv.t fundef unit. -Definition getw (rs: regset) (r: ireg0) : val := +Definition getw (rs: regset) (r: ireg) : val := match r with - | GPR r => rs r + | _ => rs r end. -Definition getl (rs: regset) (r: ireg0) : val := +Definition getl (rs: regset) (r: ireg) : val := match r with - | GPR r => rs r + | _ => rs r end. Notation "a # b" := (a b) (at level 1, only parsing) : asm. diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 2d2c2e3b..82779bf4 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -74,8 +74,8 @@ Definition loadimm32 (r: ireg) (n: int) (k: code) := | Imm32_single imm => Pmake r imm :: k end. (* -Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) - (opimm: ireg -> ireg0 -> int -> instruction) +Definition opimm32 (op: ireg -> ireg -> ireg -> instruction) + (opimm: ireg -> ireg -> int -> instruction) (rd rs: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => opimm rd rs imm :: k @@ -99,8 +99,8 @@ Definition loadimm64 (r: ireg) (n: int64) (k: code) := | Imm64_single imm => Pmakel r imm :: k end. -Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) - (opimm: ireg -> ireg0 -> int64 -> instruction) +Definition opimm64 (op: ireg -> ireg -> ireg -> instruction) + (opimm: ireg -> ireg -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with | Imm64_single imm => opimm rd rs imm :: k @@ -125,7 +125,7 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := (* (** Translation of conditional branches. *) -Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := +Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg) (lbl: label) := match cmp with | Ceq => Pbeqw r1 r2 lbl | Cne => Pbnew r1 r2 lbl @@ -135,7 +135,7 @@ Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) : | Cge => Pbgew r1 r2 lbl end. -Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := +Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg) (lbl: label) := match cmp with | Ceq => Pbeqw r1 r2 lbl | Cne => Pbnew r1 r2 lbl @@ -145,7 +145,7 @@ Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) : | Cge => Pbgeuw r1 r2 lbl end. -Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := +Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg) (lbl: label) := match cmp with | Ceq => Pbeql r1 r2 lbl | Cne => Pbnel r1 r2 lbl @@ -155,7 +155,7 @@ Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) : | Cge => Pbgel r1 r2 lbl end. -Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := +Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg) (lbl: label) := match cmp with | Ceq => Pbeql r1 r2 lbl | Cne => Pbnel r1 r2 lbl @@ -248,7 +248,7 @@ Definition transl_cbranch [rd] target register to 0 or 1 depending on the truth value of the condition. *) -Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := +Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := match cmp with | Ceq => Pseqw rd r1 r2 :: k | Cne => Psnew rd r1 r2 :: k @@ -258,7 +258,7 @@ Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: co | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k end. -Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := +Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := match cmp with | Ceq => Pseqw rd r1 r2 :: k | Cne => Psnew rd r1 r2 :: k @@ -268,7 +268,7 @@ Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: co | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k end. -Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := +Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := match cmp with | Ceq => Pseql rd r1 r2 :: k | Cne => Psnel rd r1 r2 :: k @@ -278,7 +278,7 @@ Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: co | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k end. -Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := +Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := match cmp with | Ceq => Pseql rd r1 r2 :: k | Cne => Psnel rd r1 r2 :: k diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 6957ab87..91cee038 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -217,8 +217,8 @@ Proof. Qed. *) Lemma opimm64_correct: - forall (op: ireg -> ireg0 -> ireg0 -> instruction) - (opi: ireg -> ireg0 -> int64 -> instruction) + forall (op: ireg -> ireg -> ireg -> instruction) + (opi: ireg -> ireg -> int64 -> 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) -> diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index e256661a..e51ad51f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -60,7 +60,7 @@ module Target : TARGET = let ireg oc r = output_string oc (int_reg_name r) - let ireg0 = ireg + let ireg = ireg let preg oc = function | IR r -> ireg oc r @@ -169,85 +169,85 @@ module Target : TARGET = (* 32-bit integer register-immediate instructions *) (*| Paddiw (rd, rs, imm) -> - fprintf oc " addi%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + fprintf oc " addi%t %a, %a, %a\n" w ireg rd ireg rs coqint imm | Psltiw (rd, rs, imm) -> - fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint imm + fprintf oc " slti %a, %a, %a\n" ireg rd ireg rs coqint imm | Psltiuw (rd, rs, imm) -> - fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg0 rs coqint imm + fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> - fprintf oc " andi %a, %a, %a\n" ireg rd ireg0 rs coqint imm + fprintf oc " andi %a, %a, %a\n" ireg rd ireg rs coqint imm | Poriw (rd, rs, imm) -> - fprintf oc " ori %a, %a, %a\n" ireg rd ireg0 rs coqint imm + fprintf oc " ori %a, %a, %a\n" ireg rd ireg rs coqint imm | Pxoriw (rd, rs, imm) -> - fprintf oc " xori %a, %a, %a\n" ireg rd ireg0 rs coqint imm + fprintf oc " xori %a, %a, %a\n" ireg rd ireg rs coqint imm | Pslliw (rd, rs, imm) -> - fprintf oc " slli%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + fprintf oc " slli%t %a, %a, %a\n" w ireg rd ireg rs coqint imm | Psrliw (rd, rs, imm) -> - fprintf oc " srli%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + fprintf oc " srli%t %a, %a, %a\n" w ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> - fprintf oc " srai%t %a, %a, %a\n" w ireg rd ireg0 rs coqint imm + fprintf oc " srai%t %a, %a, %a\n" w ireg rd ireg rs coqint imm | Pluiw (rd, imm) -> fprintf oc " lui %a, %a\n" ireg rd coqint imm (* 32-bit integer register-register instructions *) | Paddw(rd, rs1, rs2) -> - fprintf oc " add%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " add%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Psubw(rd, rs1, rs2) -> - fprintf oc " sub%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sub%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Pmulw(rd, rs1, rs2) -> - fprintf oc " mul%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mul%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Pmulhw(rd, rs1, rs2) -> assert (not Archi.ptr64); - fprintf oc " mulh %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mulh %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmulhuw(rd, rs1, rs2) -> assert (not Archi.ptr64); - fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pdivw(rd, rs1, rs2) -> - fprintf oc " div%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " div%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Pdivuw(rd, rs1, rs2) -> - fprintf oc " divu%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " divu%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Premw(rd, rs1, rs2) -> - fprintf oc " rem%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " rem%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Premuw(rd, rs1, rs2) -> - fprintf oc " remu%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " remu%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Psltw(rd, rs1, rs2) -> - fprintf oc " slt %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " slt %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psltuw(rd, rs1, rs2) -> - fprintf oc " sltu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sltu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw(rd, rs1, rs2) -> - fprintf oc " and %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " and %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porw(rd, rs1, rs2) -> - fprintf oc " or %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " or %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw(rd, rs1, rs2) -> - fprintf oc " xor %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " xor %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psllw(rd, rs1, rs2) -> - fprintf oc " sll%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sll%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Psrlw(rd, rs1, rs2) -> - fprintf oc " srl%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " srl%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Psraw(rd, rs1, rs2) -> - fprintf oc " sra%t %a, %a, %a\n" w ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sra%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 *)(* 64-bit integer register-immediate instructions *) | Paddil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm (*| Psltil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " slti %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " slti %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Psltiul (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andi %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " andi %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ori %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " ori %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xori %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " xori %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Psllil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " slli %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " slli %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " srli %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " srli %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Psrail (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " srai %a, %a, %a\n" ireg rd ireg0 rs coqint64 imm + fprintf oc " srai %a, %a, %a\n" ireg rd ireg rs coqint64 imm | Pluil (rd, imm) -> assert Archi.ptr64; fprintf oc " lui %a, %a\n" ireg rd coqint64 imm *) @@ -257,43 +257,43 @@ module Target : TARGET = fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm (* 64-bit integer register-register instructions *) | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 (*| Psubl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sub %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sub %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmull(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mul %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mul %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmulhl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mulh %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mulh %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmulhul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pdivl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " div %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " div %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pdivul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " divu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " divu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Preml(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " rem %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " rem %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Premul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " remu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " remu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psltl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " slt %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " slt %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psltul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sltu %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sltu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " and %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " and %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " or %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " or %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xor %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " xor %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pslll(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sll %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sll %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrll(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " srl %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " srl %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psral(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sra %a, %a, %a\n" ireg rd ireg0 rs1 ireg0 rs2 + fprintf oc " sra %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Unconditional jumps. Links are always to X1/RA. *) (* TODO: fix up arguments for calls to variadics, to move *) @@ -311,31 +311,31 @@ module Target : TARGET = (* Conditional branches, 32-bit comparisons *) | Pbeqw(rs1, rs2, l) -> - fprintf oc " beq %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " beq %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbnew(rs1, rs2, l) -> - fprintf oc " bne %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bne %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbltw(rs1, rs2, l) -> - fprintf oc " blt %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " blt %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbltuw(rs1, rs2, l) -> - fprintf oc " bltu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bltu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbgew(rs1, rs2, l) -> - fprintf oc " bge %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bge %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbgeuw(rs1, rs2, l) -> - fprintf oc " bgeu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bgeu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l (* Conditional branches, 64-bit comparisons *) | Pbeql(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " beq %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " beq %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbnel(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bne %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bne %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbltl(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " blt %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " blt %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbltul(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bltu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bltu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbgel(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bge %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bge %a, %a, %a\n" ireg rs1 ireg rs2 print_label l | Pbgeul(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bgeu %a, %a, %a\n" ireg0 rs1 ireg0 rs2 print_label l + fprintf oc " bgeu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l (* Loads and stores *) | Plb(rd, ra, ofs) -> @@ -424,18 +424,18 @@ module Target : TARGET = | Pfcvtwus (rd, fs) -> fprintf oc " fcvt.wu.s %a, %a, rtz\n" ireg rd freg fs | Pfcvtsw (fd, rs) -> - fprintf oc " fcvt.s.w %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.s.w %a, %a\n" freg fd ireg rs | Pfcvtswu (fd, rs) -> - fprintf oc " fcvt.s.wu %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.s.wu %a, %a\n" freg fd ireg rs | Pfcvtls (rd, fs) -> assert Archi.ptr64; fprintf oc " fcvt.l.s %a, %a, rtz\n" ireg rd freg fs | Pfcvtlus (rd, fs) -> assert Archi.ptr64; fprintf oc " fcvt.lu.s %a, %a, rtz\n" ireg rd freg fs | Pfcvtsl (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.s.l %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.s.l %a, %a\n" freg fd ireg rs | Pfcvtslu (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.s.lu %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.s.lu %a, %a\n" freg fd ireg rs (* 64-bit (double-precision) floating point *) | Pfld (fd, ra, ofs) | Pfld_a (fd, ra, ofs) -> @@ -485,18 +485,18 @@ module Target : TARGET = | Pfcvtwud (rd, fs) -> fprintf oc " fcvt.wu.d %a, %a, rtz\n" ireg rd freg fs | Pfcvtdw (fd, rs) -> - fprintf oc " fcvt.d.w %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.d.w %a, %a\n" freg fd ireg rs | Pfcvtdwu (fd, rs) -> - fprintf oc " fcvt.d.wu %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.d.wu %a, %a\n" freg fd ireg rs | Pfcvtld (rd, fs) -> assert Archi.ptr64; fprintf oc " fcvt.l.d %a, %a, rtz\n" ireg rd freg fs | Pfcvtlud (rd, fs) -> assert Archi.ptr64; fprintf oc " fcvt.lu.d %a, %a, rtz\n" ireg rd freg fs | Pfcvtdl (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.d.l %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.d.l %a, %a\n" freg fd ireg rs | Pfcvtdlu (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.d.lu %a, %a\n" freg fd ireg0 rs + fprintf oc " fcvt.d.lu %a, %a\n" freg fd ireg rs | Pfcvtds (fd, fs) -> fprintf oc " fcvt.d.s %a, %a\n" freg fd freg fs -- cgit From 1c1dd8c9cfcc98f183f6844b6c2f4ae60edd165d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 19 Mar 2018 11:42:30 +0100 Subject: MPPA - Activated Paddw and Paddiw + ops --- mppa_k1c/Asm.v | 16 ++++++++-------- mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 7 ++++--- mppa_k1c/TargetPrinter.ml | 12 ++++++------ 4 files changed, 22 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 4693975b..42b5f85f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -144,8 +144,8 @@ Inductive instruction : Type := | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) -(*| Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) - | Psltiw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than immediate *) + | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) +(*| Psltiw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than immediate *) | Psltiuw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than unsigned immediate *) | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or immediate *) @@ -155,8 +155,8 @@ Inductive instruction : Type := | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-arith immediate *) | Pluiw (rd: ireg) (imm: int) (**r load upper-immediate *) (** 32-bit integer register-register instructions *) - | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) - | Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) +*)| Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) +(*| Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply low *) | Pmulhw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high signed *) @@ -629,9 +629,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (rs#s))) m (** 32-bit integer register-immediate instructions *) -(*| Paddiw d s i => + | Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m - | Psltiw d s i => +(*| Psltiw d s i => Next (nextinstr (rs#d <- (Val.cmp Clt rs##s (Vint i)))) m | Psltiuw d s i => Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Clt rs##s (Vint i)))) m @@ -651,9 +651,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Vint (Int.shl i (Int.repr 12))))) m (** 32-bit integer register-register instructions *) - | Paddw d s1 s2 => +*)| Paddw d s1 s2 => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m - | Psubw d s1 s2 => +(*| Psubw d s1 s2 => Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m | Pmulw d s1 s2 => Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 82779bf4..96246bc2 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -73,16 +73,16 @@ Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => Pmake r imm :: k end. -(* + Definition opimm32 (op: ireg -> ireg -> ireg -> instruction) (opimm: ireg -> ireg -> int -> instruction) (rd rs: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => opimm rd rs imm :: k - | Imm32_pair hi lo => load_hilo32 GPR31 hi lo (op rd rs GPR31 :: k) end. Definition addimm32 := opimm32 Paddw Paddiw. +(* Definition andimm32 := opimm32 Pandw Pandiw. Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. @@ -414,13 +414,13 @@ Definition transl_op | Ocast16signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) - | Oadd, a1 :: a2 :: nil => +*)| Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddw rd rs1 rs2 :: k) | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm32 rd rs n k) - | Oneg, a1 :: nil => +(*| Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubw rd GPR0 rs :: k) | Osub, a1 :: a2 :: nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 45531e00..414527ad 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -122,7 +122,7 @@ Proof. (*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) Qed. Hint Resolve loadimm32_label: labels. -(* + Remark opimm32_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -130,10 +130,10 @@ Remark opimm32_label: tail_nolabel k (opimm32 op opimm r1 r2 n k). Proof. intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. - unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) Qed. Hint Resolve opimm32_label: labels. -*) + Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). Proof. @@ -277,6 +277,7 @@ Remark transl_op_label: Proof. Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. +- apply opimm32_label; intros; exact I. - apply opimm64_label; intros; exact I. Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index e51ad51f..71d2f22d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -168,9 +168,9 @@ module Target : TARGET = fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs (* 32-bit integer register-immediate instructions *) - (*| Paddiw (rd, rs, imm) -> - fprintf oc " addi%t %a, %a, %a\n" w ireg rd ireg rs coqint imm - | Psltiw (rd, rs, imm) -> + | Paddiw (rd, rs, imm) -> + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + (*| Psltiw (rd, rs, imm) -> fprintf oc " slti %a, %a, %a\n" ireg rd ireg rs coqint imm | Psltiuw (rd, rs, imm) -> fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg rs coqint imm @@ -190,9 +190,9 @@ module Target : TARGET = fprintf oc " lui %a, %a\n" ireg rd coqint imm (* 32-bit integer register-register instructions *) - | Paddw(rd, rs1, rs2) -> - fprintf oc " add%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Psubw(rd, rs1, rs2) -> + *)| Paddw(rd, rs1, rs2) -> + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + (*| Psubw(rd, rs1, rs2) -> fprintf oc " sub%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 | Pmulw(rd, rs1, rs2) -> -- cgit From 1743687059d4376aace1c7f211087f0c23733ec9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 20 Mar 2018 16:38:48 +0100 Subject: MPPA - "float_caller_save_regs" is not "@nil mreg" anymore. Bug in Coloring --- mppa_k1c/Conventions1.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 68beb560..99044be8 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -46,7 +46,7 @@ Definition int_caller_save_regs := :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. -Definition float_caller_save_regs := @nil mreg. +Definition float_caller_save_regs := R62 :: nil. (* FIXME - for the dummy_float_reg *) Definition int_callee_save_regs := R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 @@ -57,8 +57,8 @@ Definition float_callee_save_regs := @nil mreg. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -Definition dummy_int_reg := R0. (**r Used in [Coloring]. *) -Definition dummy_float_reg := R0. (**r Used in [Coloring]. *) +Definition dummy_int_reg := R63. (**r Used in [Coloring]. *) +Definition dummy_float_reg := R62. (**r Used in [Coloring]. *) Definition callee_save_type := mreg_type. -- cgit From 482c4d6f63113ab8486ba1773694bc7756cd0f00 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 20 Mar 2018 17:57:46 +0100 Subject: MPPA - Activated Mtailcall + Pcall --- mppa_k1c/Asm.v | 16 ++++++++++++++-- mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 6 ++++-- mppa_k1c/TargetPrinter.ml | 2 ++ 4 files changed, 24 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 42b5f85f..59b1a139 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -140,7 +140,7 @@ Inductive instruction : Type := | 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 *) | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) @@ -567,7 +567,17 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := | _ => Stuck end end. - +(* +Definition do_call (f: function) (lbl: label) (rs: regset) (m: mem) := + match label_pos lbl 0 (fn_code f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))#RA <- (rs#PC)) m + | _ => Stuck + end + end. +*) (** Auxiliaries for memory accesses *) Definition eval_offset (ofs: offset) : ptrofs := @@ -625,6 +635,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pret => Next (rs#PC <- (rs#RA)) m + | Pcall s => + Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 96246bc2..300f21a2 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -831,10 +831,10 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (Pjal_s symb sig :: k) | Mtailcall sig (inl r) => do r1 <- ireg_of r; - OK (make_epilogue f (Pj_r r1 sig :: k)) - | Mtailcall sig (inr symb) => - OK (make_epilogue f (Pj_s symb sig :: k)) -*)| Mbuiltin ef args res => + OK (make_epilogue f (Pcall :: k)) +*)| Mtailcall sig (inr symb) => + OK (make_epilogue f ((Pcall symb) :: k)) + | Mbuiltin ef args res => OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => OK (Plabel lbl :: k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 414527ad..213cb5d6 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -362,6 +362,8 @@ Lemma transl_instr_label: Proof. unfold transl_instr; intros; destruct i; TailNoLabel. - eapply transl_op_label; eauto. +- destruct s0; monadInv H; eapply tail_nolabel_trans + ; [eapply make_epilogue_label|TailNoLabel]. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. Qed. (* @@ -372,7 +374,6 @@ Qed. - eapply transl_op_label; eauto. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). - eapply transl_cbranch_label; eauto. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. @@ -829,6 +830,7 @@ Local Transparent destroyed_by_op. econstructor; eauto. apply agree_set_other; auto with asmgen. Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. +*) + (* Direct call *) exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). exploit exec_straight_steps_2; eauto using functions_transl. @@ -843,7 +845,7 @@ Local Transparent destroyed_by_op. econstructor; eauto. apply agree_set_other; auto with asmgen. Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. -*) + - (* Mbuiltin *) inv AT. monadInv H4. exploit functions_transl; eauto. intro FN. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 71d2f22d..b25804d2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -158,6 +158,8 @@ module Target : TARGET = (* Printing of instructions *) let print_instruction oc = function + | Pcall(s) -> + fprintf oc " j %a\n" symbol s | Pret -> fprintf oc " ret\n;;\n" | Pget (rd, rs) -> -- cgit From 08b52fc14b054651932469152e15eb929f802416 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Mar 2018 15:07:37 +0100 Subject: MPPA - Added Mgetstack, loadind, a bunch of loads --- mppa_k1c/Asm.v | 32 ++++++++++++++++---------------- mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 12 ++++++------ mppa_k1c/Asmgenproof1.v | 7 ++++--- mppa_k1c/TargetPrinter.ml | 6 +++--- 5 files changed, 33 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 59b1a139..521027ae 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -242,12 +242,12 @@ Inductive instruction : Type := | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int8 *) | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int16 *) | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int16 *) - | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) +*)| Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) -*)| Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) -(*| Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) + | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) + | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) +(*| Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store int16 *) | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) @@ -263,8 +263,8 @@ Inductive instruction : Type := | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) (* 32-bit (single-precision) floating point *) - | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) - | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) +*)| Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) +(*| Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) | Pfnegs (rd: freg) (rs: freg) (**r negation *) | Pfabss (rd: freg) (rs: freg) (**r absolute value *) @@ -298,8 +298,8 @@ Inductive instruction : Type := | Pfcvtslu (rd: freg) (rs: ireg) (**r unsigned int 64-> float32 conversion *) (* 64-bit (double-precision) floating point *) - | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) - | Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) +*)| Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) +(*| Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) | Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) @@ -825,15 +825,15 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mint16signed rs m d a ofs | Plhu d a ofs => exec_load Mint16unsigned rs m d a ofs - | Plw d a ofs => +*)| Plw d a ofs => exec_load Mint32 rs m d a ofs | Plw_a d a ofs => exec_load Many32 rs m d a ofs -*)| Pld d a ofs => + | Pld d a ofs => exec_load Mint64 rs m d a ofs -(*| Pld_a d a ofs => + | Pld_a d a ofs => exec_load Many64 rs m d a ofs - | Psb s a ofs => +(*| Psb s a ofs => exec_store Mint8unsigned rs m s a ofs | Psh s a ofs => exec_store Mint16unsigned rs m s a ofs @@ -851,9 +851,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (rs#s))) m (** 32-bit (single-precision) floating point *) - | Pfls d a ofs => +*)| Pfls d a ofs => exec_load Mfloat32 rs m d a ofs - | Pfss s a ofs => +(*| Pfss s a ofs => exec_store Mfloat32 rs m s a ofs | Pfnegs d s => @@ -895,9 +895,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflongu rs###s)))) m (** 64-bit (double-precision) floating point *) - | Pfld d a ofs => +*)| Pfld d a ofs => exec_load Mfloat64 rs m d a ofs - | Pfld_a d a ofs => +(*| Pfld_a d a ofs => exec_load Many64 rs m d a ofs | Pfsd s a ofs => exec_store Mfloat64 rs m s a ofs diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 300f21a2..33442dd0 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -696,7 +696,7 @@ Definition indexed_memory_access | Imm64_large imm => Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k *)end. -(* + Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := match ty, preg_of dst with | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) @@ -707,7 +707,7 @@ Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) | _, _ => Error (msg "Asmgen.loadind") end. - +(* Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := match ty, preg_of src with | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) @@ -810,9 +810,9 @@ Definition make_epilogue (f: Mach.function) (k: code) := Definition transl_instr (f: Mach.function) (i: Mach.instruction) (ep: bool) (k: code) := match i with -(*| Mgetstack ofs ty dst => + | Mgetstack ofs ty dst => loadind SP ofs ty dst k - | Msetstack src ofs ty => +(*| Msetstack src ofs ty => storeind src SP ofs ty k | Mgetparam ofs ty dst => (* load via the frame pointer if it is valid *) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 213cb5d6..d3fcc7f7 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -311,7 +311,7 @@ Proof. destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) Qed. -(* + Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. @@ -319,7 +319,7 @@ Proof. unfold loadind; intros. destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. Qed. - +(* Remark storeind_label: forall src base ofs ty k c, storeind src base ofs ty k = OK c -> tail_nolabel k c. @@ -361,13 +361,13 @@ Lemma transl_instr_label: match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. Proof. unfold transl_instr; intros; destruct i; TailNoLabel. +- eapply loadind_label; eauto. - eapply transl_op_label; eauto. - destruct s0; monadInv H; eapply tail_nolabel_trans ; [eapply make_epilogue_label|TailNoLabel]. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. Qed. (* -- eapply loadind_label; eauto. - eapply storeind_label; eauto. - destruct ep. eapply loadind_label; eauto. eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. @@ -661,15 +661,15 @@ Proof. exploit Mem.loadv_extends; eauto. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. +(* inversion TR. -(* intros [rs' [P [Q R]]]. - +*) exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. exists rs'; split. eauto. split. eapply agree_set_mreg; eauto with asmgen. congruence. simpl; congruence. -*) + - (* Msetstack *) unfold store_stack in H. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 91cee038..e339a4c9 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1196,7 +1196,7 @@ Proof. unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. intros; Simpl. Qed. -(* + Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> @@ -1213,11 +1213,12 @@ Proof. /\ forall base' ofs' rs', exec_instr ge fn (mk_instr base' ofs') rs' m = exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). - { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } + { unfold loadind in TR. + destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } destruct A as (mk_instr & B & C). subst c. eapply indexed_load_access_correct; eauto with asmgen. Qed. - +(* Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index b25804d2..5852b7f5 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -348,9 +348,9 @@ module Target : TARGET = fprintf oc " lh %a, %a(%a)\n" ireg rd offset ofs ireg ra | Plhu(rd, ra, ofs) -> fprintf oc " lhu %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) -> - fprintf oc " lw %a, %a(%a)\n" ireg rd offset ofs ireg ra - *)| Pld(rd, ra, ofs) (*| Pld_a(rd, ra, ofs)*) -> assert Archi.ptr64; + *)| Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> + fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra + | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra (*| Psb(rd, ra, ofs) -> -- cgit From 3f5f3aedb19165134b45dbf6aeea877e8ab46f6f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Mar 2018 17:05:10 +0100 Subject: MPPA - Added Mcall + Pgoto + modified Pcall --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 12 +++++++++--- mppa_k1c/TargetPrinter.ml | 4 +++- 4 files changed, 20 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 521027ae..8657bc44 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -141,6 +141,7 @@ Inductive instruction : Type := | Pset (rd: preg) (rs: ireg) (**r set system register *) | Pret (**r return *) | Pcall (l: label) (**r function call *) + | Pgoto (l: label) (**r goto *) | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** 32-bit integer register-immediate instructions *) @@ -636,6 +637,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pret => Next (rs#PC <- (rs#RA)) m | Pcall s => + Next (rs#RA <- (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + (* Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m *) + | Pgoto s => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 33442dd0..e6c99547 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -827,13 +827,13 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) transl_store chunk addr args src k | Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) - | Mcall sig (inr symb) => - OK (Pjal_s symb sig :: k) - | Mtailcall sig (inl r) => +*)| Mcall sig (inr symb) => + OK ((Pcall symb) :: k) +(*| Mtailcall sig (inl r) => do r1 <- ireg_of r; OK (make_epilogue f (Pcall :: k)) *)| Mtailcall sig (inr symb) => - OK (make_epilogue f ((Pcall symb) :: k)) + OK (make_epilogue f ((Pgoto symb) :: k)) | Mbuiltin ef args res => OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index d3fcc7f7..cbf5f166 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -363,6 +363,7 @@ Proof. unfold transl_instr; intros; destruct i; TailNoLabel. - eapply loadind_label; eauto. - eapply transl_op_label; eauto. +- destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans ; [eapply make_epilogue_label|TailNoLabel]. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. @@ -789,6 +790,7 @@ Local Transparent destroyed_by_op. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. rewrite <- H2. auto. +*) + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). @@ -803,7 +805,7 @@ Local Transparent destroyed_by_op. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. rewrite <- H2. auto. -*) + - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inversion AT; subst. @@ -843,8 +845,12 @@ Local Transparent destroyed_by_op. traceEq. (* match states *) econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. + { 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 H. auto. } - (* Mbuiltin *) inv AT. monadInv H4. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5852b7f5..fe3a57ac 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -159,7 +159,9 @@ module Target : TARGET = (* Printing of instructions *) let print_instruction oc = function | Pcall(s) -> - fprintf oc " j %a\n" symbol s + fprintf oc " call %a\n" symbol s + | Pgoto(s) -> + fprintf oc " goto %a\n" symbol s | Pret -> fprintf oc " ret\n;;\n" | Pget (rd, rs) -> -- cgit From 0a7a6ed916a95b53b63a9d4bdf1e545aacf3f82b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Mar 2018 17:19:06 +0100 Subject: MPPA - Reactivated Omove --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 4 ++++ mppa_k1c/Asmgenproof1.v | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e6c99547..3445c898 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -378,12 +378,12 @@ Definition transl_cond_op Definition transl_op (op: operation) (args: list mreg) (res: mreg) (k: code) := match op, args with -(*| Omove, a1 :: nil => + | Omove, a1 :: nil => match preg_of res, preg_of a1 with | IR r, IR a => OK (Pmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end -*)| Ointconst n, nil => + | Ointconst n, nil => do rd <- ireg_of res; OK (loadimm32 rd n k) | Olongconst n, nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index cbf5f166..afbb2e3f 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -277,7 +277,11 @@ Remark transl_op_label: Proof. Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. +(* Omove *) +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +(* ? *) - apply opimm32_label; intros; exact I. +(* ? *) - apply opimm64_label; intros; exact I. Qed. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index e339a4c9..23c0478c 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -982,9 +982,9 @@ Proof. Opaque Int.eq. intros until c; intros TR EV. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -(* - (* move *) destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +(* - (* intconst *) exploit loadimm32_correct; eauto. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. -- cgit From 447ceed8642e2ed000a20036298adb8448ac594b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Mar 2018 17:46:45 +0100 Subject: MPPA - Added Msetstack + bunch of store --> on a des call ! --- mppa_k1c/Asm.v | 32 ++++++++++++++++---------------- mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 13 ++++++++----- mppa_k1c/Asmgenproof1.v | 4 ++-- mppa_k1c/TargetPrinter.ml | 10 +++++----- 5 files changed, 35 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 8657bc44..7603a1f9 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -250,13 +250,13 @@ Inductive instruction : Type := (*| Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store int16 *) - | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) +*)| Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) -*)| Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) -(*| Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) + | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) (* Synchronization *) - | Pfence (**r fence *) +(*| Pfence (**r fence *) (* floating point register move *) | Pfmv (rd: freg) (rs: freg) (**r move *) @@ -265,9 +265,9 @@ Inductive instruction : Type := (* 32-bit (single-precision) floating point *) *)| Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) -(*| Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) + | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) - | Pfnegs (rd: freg) (rs: freg) (**r negation *) +(*| Pfnegs (rd: freg) (rs: freg) (**r negation *) | Pfabss (rd: freg) (rs: freg) (**r absolute value *) | Pfadds (rd: freg) (rs1 rs2: freg) (**r addition *) @@ -301,8 +301,8 @@ Inductive instruction : Type := (* 64-bit (double-precision) floating point *) *)| Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) (*| Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) - | Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) +*)| Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) +(*| Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) | Pfnegd (rd: freg) (rs: freg) (**r negation *) | Pfabsd (rd: freg) (rs: freg) (**r absolute value *) @@ -841,26 +841,26 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_store Mint8unsigned rs m s a ofs | Psh s a ofs => exec_store Mint16unsigned rs m s a ofs - | Psw s a ofs => +*)| Psw s a ofs => exec_store Mint32 rs m s a ofs | Psw_a s a ofs => exec_store Many32 rs m s a ofs -*)| Psd s a ofs => + | Psd s a ofs => exec_store Mint64 rs m s a ofs -(*| Psd_a s a ofs => + | Psd_a s a ofs => exec_store Many64 rs m s a ofs (** Floating point register move *) - | Pfmv d s => +(*| Pfmv d s => Next (nextinstr (rs#d <- (rs#s))) m (** 32-bit (single-precision) floating point *) *)| Pfls d a ofs => exec_load Mfloat32 rs m d a ofs -(*| Pfss s a ofs => + | Pfss s a ofs => exec_store Mfloat32 rs m s a ofs - | Pfnegs d s => +(*| Pfnegs d s => Next (nextinstr (rs#d <- (Val.negfs rs#s))) m | Pfabss d s => Next (nextinstr (rs#d <- (Val.absfs rs#s))) m @@ -903,9 +903,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mfloat64 rs m d a ofs (*| Pfld_a d a ofs => exec_load Many64 rs m d a ofs - | Pfsd s a ofs => +*)| Pfsd s a ofs => exec_store Mfloat64 rs m s a ofs - | Pfsd_a s a ofs => +(*| Pfsd_a s a ofs => exec_store Many64 rs m s a ofs | Pfnegd d s => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 3445c898..8dd23041 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -707,7 +707,7 @@ Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) | _, _ => Error (msg "Asmgen.loadind") end. -(* + Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := match ty, preg_of src with | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) @@ -719,7 +719,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) : | _, _ => Error (msg "Asmgen.storeind") end. -*) + Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := indexed_memory_access (Pld dst) base ofs k. @@ -812,9 +812,9 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) match i with | Mgetstack ofs ty dst => loadind SP ofs ty dst k -(*| Msetstack src ofs ty => + | Msetstack src ofs ty => storeind src SP ofs ty k - | Mgetparam ofs ty dst => +(*| Mgetparam ofs ty dst => (* load via the frame pointer if it is valid *) do c <- loadind GPR30 ofs ty dst k; OK (if ep then c diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index afbb2e3f..5d6c21c8 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -323,7 +323,7 @@ Proof. unfold loadind; intros. destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. Qed. -(* + Remark storeind_label: forall src base ofs ty k c, storeind src base ofs ty k = OK c -> tail_nolabel k c. @@ -331,7 +331,7 @@ Proof. unfold storeind; intros. destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. Qed. -*) + Remark loadind_ptr_label: forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). Proof. @@ -365,7 +365,10 @@ Lemma transl_instr_label: match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. Proof. unfold transl_instr; intros; destruct i; TailNoLabel. +(* loadind *) - eapply loadind_label; eauto. +(* storeind *) +- eapply storeind_label; eauto. - eapply transl_op_label; eauto. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans @@ -373,7 +376,7 @@ Proof. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. Qed. (* -- eapply storeind_label; eauto. + - destruct ep. eapply loadind_label; eauto. eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. - eapply transl_op_label; eauto. @@ -683,11 +686,11 @@ Proof. left; eapply exec_straight_steps; eauto. rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. inversion TR. -(*exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. exists rs'; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. simpl; intros. rewrite Q; auto with asmgen. -*) + - (* Mgetparam *) assert (f0 = f) by congruence; subst f0. unfold load_stack in *. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 23c0478c..635f37dc 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1218,7 +1218,7 @@ Proof. destruct A as (mk_instr & B & C). subst c. eapply indexed_load_access_correct; eauto with asmgen. Qed. -(* + Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> @@ -1238,7 +1238,7 @@ Proof. destruct A as (mk_instr & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. Qed. -*) + Lemma Pget_correct: forall (dst: gpreg) (src: preg) k (rs: regset) m, diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index fe3a57ac..913127df 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -159,9 +159,9 @@ module Target : TARGET = (* Printing of instructions *) let print_instruction oc = function | Pcall(s) -> - fprintf oc " call %a\n" symbol s + fprintf oc " call %a\n;;\n" symbol s | Pgoto(s) -> - fprintf oc " goto %a\n" symbol s + fprintf oc " goto %a\n;;\n" symbol s | Pret -> fprintf oc " ret\n;;\n" | Pget (rd, rs) -> @@ -359,9 +359,9 @@ module Target : TARGET = fprintf oc " sb %a, %a(%a)\n" ireg rd offset ofs ireg ra | Psh(rd, ra, ofs) -> fprintf oc " sh %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) -> - fprintf oc " sw %a, %a(%a)\n" ireg rd offset ofs ireg ra - *)| Psd(rd, ra, ofs) (*| Psd_a(rd, ra, ofs)*) -> assert Archi.ptr64; + *)| Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> + fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd + | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd -- cgit From c81c303db03ba732bda8612381e8569db181a541 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 23 Mar 2018 15:32:36 +0100 Subject: MPPA - mppa_call branch cleaning --- mppa_k1c/Asm.v | 13 +------------ mppa_k1c/Asmgen.v | 3 +-- mppa_k1c/Asmgenproof.v | 10 +++------- mppa_k1c/Asmgenproof1.v | 2 +- 4 files changed, 6 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 7603a1f9..707273a6 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -568,17 +568,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := | _ => Stuck end end. -(* -Definition do_call (f: function) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 (fn_code f) with - | None => Stuck - | Some pos => - match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))#RA <- (rs#PC)) m - | _ => Stuck - end - end. -*) + (** Auxiliaries for memory accesses *) Definition eval_offset (ofs: offset) : ptrofs := @@ -638,7 +628,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (rs#PC <- (rs#RA)) m | Pcall s => Next (rs#RA <- (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - (* Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m *) | Pgoto s => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pmv d s => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 8dd23041..c6f7ef11 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -707,7 +707,7 @@ Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) | _, _ => Error (msg "Asmgen.loadind") end. - + Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := match ty, preg_of src with | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) @@ -719,7 +719,6 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) : | _, _ => Error (msg "Asmgen.storeind") end. - Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := indexed_memory_access (Pld dst) base ofs k. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 5d6c21c8..88e42d1e 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -279,9 +279,9 @@ Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. (* Omove *) - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -(* ? *) +(* Oaddimm32 *) - apply opimm32_label; intros; exact I. -(* ? *) +(* Oaddimm64 *) - apply opimm64_label; intros; exact I. Qed. @@ -372,7 +372,7 @@ Proof. - eapply transl_op_label; eauto. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans - ; [eapply make_epilogue_label|TailNoLabel]. + ; [eapply make_epilogue_label|TailNoLabel]. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. Qed. (* @@ -669,10 +669,6 @@ Proof. exploit Mem.loadv_extends; eauto. intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. left; eapply exec_straight_steps; eauto. intros. simpl in TR. -(* - inversion TR. - intros [rs' [P [Q R]]]. -*) exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. exists rs'; split. eauto. split. eapply agree_set_mreg; eauto with asmgen. congruence. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 635f37dc..b3965bb9 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1213,7 +1213,7 @@ Proof. /\ forall base' ofs' rs', exec_instr ge fn (mk_instr base' ofs') rs' m = exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). - { unfold loadind in TR. + { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } destruct A as (mk_instr & B & C). subst c. eapply indexed_load_access_correct; eauto with asmgen. -- cgit From 8d196f0f3193758a6371d9eb539af350202e0f4f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 23 Mar 2018 15:58:21 +0100 Subject: MPPA - Added Mgoto + Pj_l --- mppa_k1c/Asm.v | 8 ++++---- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 2 -- mppa_k1c/TargetPrinter.ml | 2 +- 4 files changed, 7 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 707273a6..82ec101c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -216,8 +216,8 @@ Inductive instruction : Type := | Pcvtw2l (r: ireg) (**r int32 signed -> int64 (pseudo) *) (* Unconditional jumps. Links are always to X1/RA. *) - | Pj_l (l: label) (**r jump to label *) - | Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) +*)| Pj_l (l: label) (**r jump to label *) +(*| Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) | Pj_r (r: ireg) (sg: signature) (**r jump register *) | Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) @@ -767,9 +767,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#r <- (Val.longofint rs#r))) m (** Unconditional jumps. Links are always to X1/RA. *) - | Pj_l l => +*)| Pj_l l => goto_label f l rs m - | Pj_s s sg => +(*| Pj_s s sg => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pj_r r sg => Next (rs#PC <- (rs#r)) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index c6f7ef11..69faf1f9 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -837,9 +837,9 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) | Mlabel lbl => OK (Plabel lbl :: k) -(*| Mgoto lbl => + | Mgoto lbl => OK (Pj_l lbl :: k) - | Mcond cond args lbl => +(*| Mcond cond args lbl => transl_cbranch cond args lbl k | Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) *)| Mreturn => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 88e42d1e..068a2731 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -884,7 +884,6 @@ Local Transparent destroyed_by_op. - (* Mgoto *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H4. -(* exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. left; exists (State rs' m'); split. apply plus_one. econstructor; eauto. @@ -894,7 +893,6 @@ Local Transparent destroyed_by_op. econstructor; eauto. eapply agree_exten; eauto with asmgen. congruence. -*) - (* Mcond true *) assert (f0 = f) by congruence. subst f0. exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 913127df..280dd17b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -160,7 +160,7 @@ module Target : TARGET = let print_instruction oc = function | Pcall(s) -> fprintf oc " call %a\n;;\n" symbol s - | Pgoto(s) -> + | Pgoto(s) | Pj_l(s) -> fprintf oc " goto %a\n;;\n" symbol s | Pret -> fprintf oc " ret\n;;\n" -- cgit From 69813ed0107cd76caa322db5e1df1b7b969b7012 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Apr 2018 17:07:09 +0200 Subject: MPPA - 32-bits immediate eq/neq branches --- mppa_k1c/Asm.v | 354 ++++++++++++++++---------------------------- mppa_k1c/Asmgen.v | 213 +-------------------------- mppa_k1c/Asmgenproof.v | 18 +-- mppa_k1c/Asmgenproof1.v | 254 +++++++++++--------------------- mppa_k1c/TargetPrinter.ml | 363 +++++----------------------------------------- 5 files changed, 258 insertions(+), 944 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 82ec101c..d769062f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -92,6 +92,44 @@ Module Pregmap := EMap(PregEq). (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'RTMP'" := GPR31 (only parsing) : asm. + +Inductive btest: Type := +(*| BTdnez (**r Double Not Equal to Zero *) + | BTdeqz (**r Double Equal to Zero *) + | BTdltz (**r Double Less Than Zero *) + | 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 *) + | BTweqz (**r Word Equal to Zero *) +(*| BTwltz (**r Word Less Than Zero *) + | BTwgez (**r Word Greater Than or Equal to Zero *) + | BTwlez (**r Word Less Than or Equal to Zero *) + | BTwgtz (**r Word Greater Than Zero *) +*). + +Inductive itest: Type := + | ITne (**r Not Equal *) + | ITeq (**r Equal *) + | ITlt (**r Less Than *) + | ITge (**r Greater Than or Equal *) + | ITle (**r Less Than or Equal *) + | ITgt (**r Greater Than *) + | ITneu (**r Unsigned Not Equal *) + | ITequ (**r Unsigned Equal *) + | ITltu (**r Less Than Unsigned *) + | 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 *) + . (** Offsets for load and store instructions. An offset is either an immediate integer or the low part of a symbol. *) @@ -136,121 +174,46 @@ Definition label := positive. [Asmgen]) is careful to respect this range. *) Inductive instruction : Type := +(** System Registers *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) (** Branch Control Unit 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 *) - | Pgoto (l: label) (**r goto *) - | Pmv (rd: ireg) (rs: ireg) (**r integer move *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Pgoto (l: label) (**r goto *) + +(** Register move *) + | Pmv (rd: ireg) (rs: ireg) (**r integer move *) + +(** Comparisons *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) -(*| Psltiw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than immediate *) - | Psltiuw (rd: ireg) (rs: ireg) (imm: int) (**r set-less-than unsigned immediate *) - | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) - | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or immediate *) - | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor immediate *) - | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift-left-logical immediate *) - | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-logical immediate *) - | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-arith immediate *) - | Pluiw (rd: ireg) (imm: int) (**r load upper-immediate *) + (** 32-bit integer register-register instructions *) -*)| Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) -(*| Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) - - | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply low *) - | Pmulhw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high signed *) - | Pmulhuw (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high unsigned *) - | Pdivw (rd: ireg) (rs1 rs2: ireg) (**r integer division *) - | Pdivuw (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer division *) - | Premw (rd: ireg) (rs1 rs2: ireg) (**r integer remainder *) - | Premuw (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer remainder *) - | Psltw (rd: ireg) (rs1 rs2: ireg) (**r set-less-than *) - | Psltuw (rd: ireg) (rs1 rs2: ireg) (**r set-less-than unsigned *) - | Pseqw (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 == rs2] (pseudo) *) - | Psnew (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 != rs2] (pseudo) *) - | Pandw (rd: ireg) (rs1 rs2: ireg) (**r bitwise and *) - | Porw (rd: ireg) (rs1 rs2: ireg) (**r bitwise or *) - | Pxorw (rd: ireg) (rs1 rs2: ireg) (**r bitwise xor *) - | Psllw (rd: ireg) (rs1 rs2: ireg) (**r shift-left-logical *) - | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift-right-logical *) - | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift-right-arith *) + | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) (** 64-bit integer register-immediate instructions *) -*)| Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) (* - | Psltil (rd: ireg) (rs: ireg) (imm: int64) (**r set-less-than immediate *) - | Psltiul (rd: ireg) (rs: ireg) (imm: int64) (**r set-less-than unsigned immediate *) - | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) - | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or immediate *) - | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor immediate *) - | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift-left-logical immediate *) - | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-logical immediate *) - | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift-right-arith immediate *) - | Pluil (rd: ireg) (imm: int64) (**r FIXME - remove it ; load upper-immediate *) -*)| Pmake (rd: ireg) (imm: int) (**r load immediate *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + (** 64-bit integer register-register instructions *) - | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) (* - | Psubl (rd: ireg) (rs1 rs2: ireg) (**r integer subtraction *) - - | Pmull (rd: ireg) (rs1 rs2: ireg) (**r integer multiply low *) - | Pmulhl (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high signed *) - | Pmulhul (rd: ireg) (rs1 rs2: ireg) (**r integer multiply high unsigned *) - | Pdivl (rd: ireg) (rs1 rs2: ireg) (**r integer division *) - | Pdivul (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer division *) - | Preml (rd: ireg) (rs1 rs2: ireg) (**r integer remainder *) - | Premul (rd: ireg) (rs1 rs2: ireg) (**r unsigned integer remainder *) - | Psltl (rd: ireg) (rs1 rs2: ireg) (**r set-less-than *) - | Psltul (rd: ireg) (rs1 rs2: ireg) (**r set-less-than unsigned *) - | Pseql (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 == rs2] (pseudo) *) - | Psnel (rd: ireg) (rs1 rs2: ireg) (**r [rd <- rs1 != rs2] (pseudo) *) - | Pandl (rd: ireg) (rs1 rs2: ireg) (**r bitwise and *) - | Porl (rd: ireg) (rs1 rs2: ireg) (**r bitwise or *) - | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r bitwise xor *) - | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift-left-logical *) - | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift-right-logical *) - | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift-right-arith *) - - | Pcvtl2w (rd: ireg) (rs: ireg) (**r int64->int32 (pseudo) *) - | Pcvtw2l (r: ireg) (**r int32 signed -> int64 (pseudo) *) + | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) (* Unconditional jumps. Links are always to X1/RA. *) -*)| Pj_l (l: label) (**r jump to label *) -(*| Pj_s (symb: ident) (sg: signature) (**r jump to symbol *) - | Pj_r (r: ireg) (sg: signature) (**r jump register *) - | Pjal_s (symb: ident) (sg: signature) (**r jump-and-link symbol *) - | Pjal_r (r: ireg) (sg: signature) (**r jump-and-link register *) - - (* Conditional branches, 32-bit comparisons *) - | Pbeqw (rs1 rs2: ireg) (l: label) (**r branch-if-equal *) - | Pbnew (rs1 rs2: ireg) (l: label) (**r branch-if-not-equal signed *) - | Pbltw (rs1 rs2: ireg) (l: label) (**r branch-if-less signed *) - | Pbltuw (rs1 rs2: ireg) (l: label) (**r branch-if-less unsigned *) - | Pbgew (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal signed *) - | Pbgeuw (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal unsigned *) - - (* Conditional branches, 64-bit comparisons *) - | Pbeql (rs1 rs2: ireg) (l: label) (**r branch-if-equal *) - | Pbnel (rs1 rs2: ireg) (l: label) (**r branch-if-not-equal signed *) - | Pbltl (rs1 rs2: ireg) (l: label) (**r branch-if-less signed *) - | Pbltul (rs1 rs2: ireg) (l: label) (**r branch-if-less unsigned *) - | Pbgel (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal signed *) - | Pbgeul (rs1 rs2: ireg) (l: label) (**r branch-if-greater-or-equal unsigned *) - - (* Loads and stores *) - | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int8 *) - | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int8 *) - | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load signed int16 *) - | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load unsigned int16 *) -*)| Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) + | Pj_l (l: label) (**r jump to label *) + + (* Conditional branches *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + + | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) -(*| Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store int8 *) - | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store int16 *) -*)| Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) + | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) @@ -600,6 +563,45 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti | None => Stuck end. +Inductive signedness: Type := Signed | Unsigned. + +Definition itest_for_cmp (c: comparison) (s: signedness) := + match c, s with + | Cne, Signed => ITne + | Ceq, Signed => ITeq + | Clt, Signed => ITlt + | Cge, Signed => ITge + | Cle, Signed => ITle + | Cgt, Signed => ITgt + | Cne, Unsigned => ITneu + | Ceq, Unsigned => ITequ + | Clt, Unsigned => ITltu + | Cge, Unsigned => ITgeu + | Cle, Unsigned => ITleu + | Cgt, Unsigned => ITgtu + end. + +(** Comparing integers *) +Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := + match t with + | ITne => Val.cmp Cne v1 v2 + | ITeq => Val.cmp Ceq v1 v2 + | ITlt => Val.cmp Clt v1 v2 + | ITge => Val.cmp Cge v1 v2 + | ITle => Val.cmp Cle v1 v2 + | ITgt => Val.cmp Cgt v1 v2 + | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Vundef + end. + (** Execution of a single instruction [i] in initial state [rs] and [m]. Return updated state. For instructions that correspond to actual RISC-V instructions, the cases are straightforward @@ -633,90 +635,23 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmv d s => Next (nextinstr (rs#d <- (rs#s))) m +(** Comparisons *) + | Pcompw c d s1 s2 => + (* Next (nextinstr (rs#d <- (Val.cmp Cne rs##s1 rs##s2))) m *) + Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m + (** 32-bit integer register-immediate instructions *) | Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m -(*| Psltiw d s i => - Next (nextinstr (rs#d <- (Val.cmp Clt rs##s (Vint i)))) m - | Psltiuw d s i => - Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Clt rs##s (Vint i)))) m - | Pandiw d s i => - Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m - | Poriw d s i => - Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m - | Pxoriw d s i => - Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m - | Pslliw d s i => - Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m - | Psrliw d s i => - Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m - | Psraiw d s i => - Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m - | Pluiw d i => - Next (nextinstr (rs#d <- (Vint (Int.shl i (Int.repr 12))))) m (** 32-bit integer register-register instructions *) -*)| Paddw d s1 s2 => + | Paddw d s1 s2 => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m -(*| Psubw d s1 s2 => - Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m - | Pmulw d s1 s2 => - Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m - | Pmulhw d s1 s2 => - Next (nextinstr (rs#d <- (Val.mulhs rs##s1 rs##s2))) m - | Pmulhuw d s1 s2 => - Next (nextinstr (rs#d <- (Val.mulhu rs##s1 rs##s2))) m - | Pdivw d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.divs rs##s1 rs##s2)))) m - | Pdivuw d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.divu rs##s1 rs##s2)))) m - | Premw d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.mods rs##s1 rs##s2)))) m - | Premuw d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.modu rs##s1 rs##s2)))) m - | Psltw d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmp Clt rs##s1 rs##s2))) m - | Psltuw d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Clt rs##s1 rs##s2))) m - | Pseqw d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Ceq rs##s1 rs##s2))) m - | Psnew d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpu (Mem.valid_pointer m) Cne rs##s1 rs##s2))) m - | Pandw d s1 s2 => - Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m - | Porw d s1 s2 => - Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m - | Pxorw d s1 s2 => - Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m - | Psllw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m - | Psrlw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m - | Psraw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m (** 64-bit integer register-immediate instructions *) -*)| Paddil d s i => + | Paddil d s i => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m -(*| Psltil d s i => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmpl Clt rs###s (Vlong i))))) m - | Psltiul d s i => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt rs###s (Vlong i))))) m - | Pandil d s i => - Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m - | Poril d s i => - Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m - | Pxoril d s i => - Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m - | Psllil d s i => - Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m - | Psrlil d s i => - Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m - | Psrail d s i => - Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m - | Pluil d i => - Next (nextinstr (rs#d <- (Vlong (Int64.sign_ext 32 (Int64.shl i (Int64.repr 12)))))) m -*)| Pmakel d i => + | Pmakel d i => Next (nextinstr (rs#d <- (Vlong i))) m | Pmake d i => Next (nextinstr (rs#d <- (Vint i))) m @@ -724,63 +659,18 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m -(*| Psubl d s1 s2 => - Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m - | Pmull d s1 s2 => - Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m - | Pmulhl d s1 s2 => - Next (nextinstr (rs#d <- (Val.mullhs rs###s1 rs###s2))) m - | Pmulhul d s1 s2 => - Next (nextinstr (rs#d <- (Val.mullhu rs###s1 rs###s2))) m - | Pdivl d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.divls rs###s1 rs###s2)))) m - | Pdivul d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.divlu rs###s1 rs###s2)))) m - | Preml d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.modls rs###s1 rs###s2)))) m - | Premul d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.modlu rs###s1 rs###s2)))) m - | Psltl d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmpl Clt rs###s1 rs###s2)))) m - | Psltul d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt rs###s1 rs###s2)))) m - | Pseql d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq rs###s1 rs###s2)))) m - | Psnel d s1 s2 => - Next (nextinstr (rs#d <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cne rs###s1 rs###s2)))) m - | Pandl d s1 s2 => - Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m - | Porl d s1 s2 => - Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m - | Pxorl d s1 s2 => - Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m - | Pslll d s1 s2 => - Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m - | Psrll d s1 s2 => - Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m - | Psral d s1 s2 => - Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m - - | Pcvtl2w d s => - Next (nextinstr (rs#d <- (Val.loword rs##s))) m - | Pcvtw2l r => - Next (nextinstr (rs#r <- (Val.longofint rs#r))) m - -(** Unconditional jumps. Links are always to X1/RA. *) -*)| Pj_l l => + +(** Unconditional jumps. *) + | Pj_l l => goto_label f l rs m -(*| Pj_s s sg => - Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pj_r r sg => - Next (rs#PC <- (rs#r)) m - | Pjal_s s sg => - Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero) - #RA <- (Val.offset_ptr rs#PC Ptrofs.one) - ) m - | Pjal_r r sg => - Next (rs#PC <- (rs#r) - #RA <- (Val.offset_ptr rs#PC Ptrofs.one) - ) m + +(** Conditional branches *) + | Pcb bt r l => + match bt with + | BTwnez => eval_branch f l rs m (Val.cmp_bool Cne rs##r (Vint (Int.repr 0))) + | _ => Stuck + end +(* (** Conditional branches, 32-bit comparisons *) | Pbeqw s1 s2 l => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Ceq rs##s1 rs##s2) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 69faf1f9..4b249f91 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -122,212 +122,18 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := else addimm64 rd rs (Ptrofs.to_int64 n) k. -(* (** Translation of conditional branches. *) -Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg) (lbl: label) := - match cmp with - | Ceq => Pbeqw r1 r2 lbl - | Cne => Pbnew r1 r2 lbl - | Clt => Pbltw r1 r2 lbl - | Cle => Pbgew r2 r1 lbl - | Cgt => Pbltw r2 r1 lbl - | Cge => Pbgew r1 r2 lbl - end. - -Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg) (lbl: label) := - match cmp with - | Ceq => Pbeqw r1 r2 lbl - | Cne => Pbnew r1 r2 lbl - | Clt => Pbltuw r1 r2 lbl - | Cle => Pbgeuw r2 r1 lbl - | Cgt => Pbltuw r2 r1 lbl - | Cge => Pbgeuw r1 r2 lbl - end. - -Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg) (lbl: label) := - match cmp with - | Ceq => Pbeql r1 r2 lbl - | Cne => Pbnel r1 r2 lbl - | Clt => Pbltl r1 r2 lbl - | Cle => Pbgel r2 r1 lbl - | Cgt => Pbltl r2 r1 lbl - | Cge => Pbgel r1 r2 lbl - end. - -Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg) (lbl: label) := - match cmp with - | Ceq => Pbeql r1 r2 lbl - | Cne => Pbnel r1 r2 lbl - | Clt => Pbltul r1 r2 lbl - | Cle => Pbgeul r2 r1 lbl - | Cgt => Pbltul r2 r1 lbl - | Cge => Pbgeul r1 r2 lbl - end. +Definition transl_comp + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompw (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. -Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := - match cmp with - | Ceq => (Pfeqd rd fs1 fs2, true) - | Cne => (Pfeqd rd fs1 fs2, false) - | Clt => (Pfltd rd fs1 fs2, true) - | Cle => (Pfled rd fs1 fs2, true) - | Cgt => (Pfltd rd fs2 fs1, true) - | Cge => (Pfled rd fs2 fs1, true) - end. - -Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := - match cmp with - | Ceq => (Pfeqs rd fs1 fs2, true) - | Cne => (Pfeqs rd fs1 fs2, false) - | Clt => (Pflts rd fs1 fs2, true) - | Cle => (Pfles rd fs1 fs2, true) - | Cgt => (Pflts rd fs2 fs1, true) - | Cge => (Pfles rd fs2 fs1, true) - end. - Definition transl_cbranch - (cond: condition) (args: list mreg) (lbl: label) (k: code) := + (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int32s c r1 r2 lbl :: k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int32u c r1 r2 lbl :: k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - transl_cbranch_int32s c r1 GPR0 lbl :: k - else - loadimm32 GPR31 n (transl_cbranch_int32s c r1 GPR31 lbl :: k)) | Ccompuimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - transl_cbranch_int32u c r1 GPR0 lbl :: k - else - loadimm32 GPR31 n (transl_cbranch_int32u c r1 GPR31 lbl :: k)) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int64s c r1 r2 lbl :: k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int64u c r1 r2 lbl :: k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - transl_cbranch_int64s c r1 GPR0 lbl :: k - else - loadimm64 GPR31 n (transl_cbranch_int64s c r1 GPR31 lbl :: k)) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - transl_cbranch_int64u c r1 GPR0 lbl :: k - else - loadimm64 GPR31 n (transl_cbranch_int64u c r1 GPR31 lbl :: k)) - | Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c GPR31 r1 r2 in - OK (insn :: (if normal then Pbnew GPR31 GPR0 lbl else Pbeqw GPR31 GPR0 lbl) :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c GPR31 r1 r2 in - OK (insn :: (if normal then Pbeqw GPR31 GPR0 lbl else Pbnew GPR31 GPR0 lbl) :: k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c GPR31 r1 r2 in - OK (insn :: (if normal then Pbnew GPR31 GPR0 lbl else Pbeqw GPR31 GPR0 lbl) :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c GPR31 r1 r2 in - OK (insn :: (if normal then Pbeqw GPR31 GPR0 lbl else Pbnew GPR31 GPR0 lbl) :: k) - | _, _ => - Error(msg "Asmgen.transl_cond_branch") - end. - -(** Translation of a condition operator. The generated code sets the - [rd] target register to 0 or 1 depending on the truth value of the - condition. *) - -Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := - match cmp with - | Ceq => Pseqw rd r1 r2 :: k - | Cne => Psnew rd r1 r2 :: k - | Clt => Psltw rd r1 r2 :: k - | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltw rd r2 r1 :: k - | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := - match cmp with - | Ceq => Pseqw rd r1 r2 :: k - | Cne => Psnew rd r1 r2 :: k - | Clt => Psltuw rd r1 r2 :: k - | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltuw rd r2 r1 :: k - | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := - match cmp with - | Ceq => Pseql rd r1 r2 :: k - | Cne => Psnel rd r1 r2 :: k - | Clt => Psltl rd r1 r2 :: k - | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltl rd r2 r1 :: k - | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg) (k: code) := - match cmp with - | Ceq => Pseql rd r1 r2 :: k - | Cne => Psnel rd r1 r2 :: k - | Clt => Psltul rd r1 r2 :: k - | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k - | Cgt => Psltul rd r2 r1 :: k - | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k - end. - -Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 GPR0 k else - match cmp with - | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd GPR0 k) - | Clt => sltimm32 rd r1 n k - | Cle => if Int.eq n (Int.repr Int.max_signed) - then loadimm32 rd Int.one k - else sltimm32 rd r1 (Int.add n Int.one) k - | _ => loadimm32 GPR31 n (transl_cond_int32s cmp rd r1 GPR31 k) - end. - -Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := - if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 GPR0 k else - match cmp with - | Clt => sltuimm32 rd r1 n k - | _ => loadimm32 GPR31 n (transl_cond_int32u cmp rd r1 GPR31 k) - end. - -Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 GPR0 k else - match cmp with - | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd GPR0 k) - | Clt => sltimm64 rd r1 n k - | Cle => if Int64.eq n (Int64.repr Int64.max_signed) - then loadimm32 rd Int.one k - else sltimm64 rd r1 (Int64.add n Int64.one) k - | _ => loadimm64 GPR31 n (transl_cond_int64s cmp rd r1 GPR31 k) - end. - -Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := - if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 GPR0 k else - match cmp with - | Clt => sltuimm64 rd r1 n k - | _ => loadimm64 GPR31 n (transl_cond_int64u cmp rd r1 GPR31 k) - end. -*) - -Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: code) : res (list instruction) := - match cond, args with + OK (loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k)) (*| Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_int32s c rd r1 r2 k) @@ -337,9 +143,6 @@ Definition transl_cond_op | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (transl_condimm_int32s c rd r1 n k) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32u c rd r1 n k) | Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_int64s c rd r1 r2 k) @@ -369,7 +172,7 @@ Definition transl_cond_op let (insn, normal) := transl_cond_single c rd r1 r2 in OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) *)| _, _ => - Error(msg "Asmgen.transl_cond_op") + Error(msg "Asmgen.transl_cbranch") end. (** Translation of the arithmetic operation [r <- op(args)]. @@ -839,9 +642,9 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) OK (Plabel lbl :: k) | Mgoto lbl => OK (Pj_l lbl :: k) -(*| Mcond cond args lbl => + | Mcond cond args lbl => transl_cbranch cond args lbl k - | Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) +(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) *)| Mreturn => OK (make_epilogue f (Pret :: k)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 068a2731..dd495cd4 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -174,12 +174,16 @@ Remark transl_cond_single_nolabel: Proof. unfold transl_cond_single; intros. destruct c; inv H; exact I. Qed. - +*) Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. - intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. + intros. unfold transl_cbranch in H. (* unfold transl_cond_op in H. *) destruct cond; TailNoLabel. + - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. +Qed. + +(* - destruct c0; simpl; TailNoLabel. - destruct c0; simpl; TailNoLabel. - destruct (Int.eq n Int.zero). @@ -212,8 +216,8 @@ Proof. - destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. -Qed. *) +(* Remark transl_cond_op_label: forall cond args r k c, transl_cond_op cond r args k = OK c -> tail_nolabel k c. @@ -270,7 +274,7 @@ Proof. destruct normal; TailNoLabel. *) Qed. - +*) Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. @@ -373,6 +377,7 @@ Proof. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans ; [eapply make_epilogue_label|TailNoLabel]. +- eapply transl_cbranch_label; eauto. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. Qed. (* @@ -383,7 +388,6 @@ Qed. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). -- eapply transl_cbranch_label; eauto. - eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. *) @@ -899,24 +903,20 @@ Local Transparent destroyed_by_op. left; eapply exec_straight_opt_steps_goto; eauto. intros. simpl in TR. inversion TR. -(* exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). exists jmp; exists k; exists rs'. split. eexact A. split. apply agree_exten with rs0; auto with asmgen. exact B. -*) - (* Mcond false *) exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. left; eapply exec_straight_steps; eauto. intros. simpl in TR. inversion TR. -(* exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). exists rs'. split. eexact A. split. apply agree_exten with rs0; auto with asmgen. simpl. congruence. -*) - (* Mjumptable *) assert (f0 = f) by congruence. subst f0. inv AT. monadInv H6. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index b3965bb9..e16dbbaf 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -21,16 +21,16 @@ Require Import Op Locations Mach Conventions. Require Import Asm Asmgen Asmgenproof0. (** Decomposition of integer constants. *) -(* + Lemma make_immed32_sound: forall n, match make_immed32 n with | Imm32_single imm => n = imm - | Imm32_pair hi lo => n = Int.add (Int.shl hi (Int.repr 12)) lo end. Proof. intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). - predSpec Int.eq Int.eq_spec n lo. + predSpec Int.eq Int.eq_spec n lo; auto. +(* - auto. - set (m := Int.sub n lo). assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). @@ -54,8 +54,9 @@ Proof. rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). rewrite D. apply Int.add_zero. -Qed. *) +Qed. + Lemma make_immed64_sound: forall n, match make_immed64 n with @@ -128,7 +129,7 @@ Proof. split. Simpl. intros; Simpl. Qed. - +*) Lemma loadimm32_correct: forall rd n k rs m, exists rs', @@ -140,11 +141,10 @@ Proof. destruct (make_immed32 n). - subst imm. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int.add_zero_l; Simpl. + split. Simpl. intros; Simpl. -- rewrite E. apply load_hilo32_correct. Qed. - +(* Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int -> instruction) @@ -281,7 +281,8 @@ Qed. Lemma addptrofs_correct_2: forall rd r1 n k (rs: regset) m b ofs, - r1 <> GPR31 -> rs#r1 = Vptr b ofs -> + r1 <> GPR31 -> 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) @@ -294,91 +295,6 @@ Qed. (** Translation of conditional branches *) -Lemma transl_cbranch_int32s_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H. -- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. - simpl; auto. -- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. - simpl; auto. -- auto. -- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. -- auto. -Qed. - -Lemma transl_cbranch_int32u_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H; auto. -- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. -Qed. - -Lemma transl_cbranch_int64s_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H. -- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. - simpl; auto. -- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. - simpl; auto. -- auto. -- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. -- auto. -Qed. - -Lemma transl_cbranch_int64u_correct: - forall cmp r1 r2 lbl (rs: regset) m b, - Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct cmp; simpl; rewrite ? H; auto. -- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. -- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. -Qed. - -Lemma transl_cond_float_correct: - forall (rs: regset) m cmp rd r1 r2 insn normal v, - transl_cond_float cmp rd r1 r2 = (insn, normal) -> - v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> - exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. -Proof. - intros. destruct cmp; simpl in H; inv H; auto. -- rewrite Val.negate_cmpf_eq. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. - rewrite <- Float.cmp_swap. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. - rewrite <- Float.cmp_swap. auto. -Qed. - -Lemma transl_cond_single_correct: - forall (rs: regset) m cmp rd r1 r2 insn normal v, - transl_cond_single cmp rd r1 r2 = (insn, normal) -> - v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> - exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. -Proof. - intros. destruct cmp; simpl in H; inv H; auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite <- Float32.cmp_swap. auto. -- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. - rewrite <- Float32.cmp_swap. auto. -Qed. - Remark branch_on_GPR31: forall normal lbl (rs: regset) m b, rs#GPR31 = Val.of_bool (eqb normal b) -> @@ -388,6 +304,7 @@ Proof. intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. Qed. *) + Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -417,7 +334,63 @@ Remark exec_straight_opt_right: Proof. destruct 1; intros. auto. eapply exec_straight_trans; eauto. Qed. -(* + +Lemma transl_comp_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs##r1 rs##r2) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2) as cmpubool. + destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + + Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -427,7 +400,7 @@ Lemma transl_cbranch_correct_1: exists rs', exists insn, exec_straight_opt c rs m' (insn :: k) rs' m' /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TRANSL EVAL AG MEXT. set (vl' := map rs (map preg_of args)). @@ -435,84 +408,19 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. -- exists rs, (transl_cbranch_int32s c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. -- exists rs, (transl_cbranch_int32u c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. -- predSpec Int.eq Int.eq_spec n Int.zero. -+ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. -+ exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32s c0 x GPR31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int32s_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- predSpec Int.eq Int.eq_spec n Int.zero. -+ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. -+ exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int32u c0 x GPR31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int32u_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- exists rs, (transl_cbranch_int64s c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. -- exists rs, (transl_cbranch_int64u c0 x x0 lbl). - intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. -- predSpec Int64.eq Int64.eq_spec n Int64.zero. -+ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. -+ exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64s c0 x GPR31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int64s_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- predSpec Int64.eq Int64.eq_spec n Int64.zero. -+ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). - intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. -+ exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exists rs', (transl_cbranch_int64u c0 x GPR31 lbl). - split. constructor; eexact A. split; auto. - apply transl_cbranch_int64u_correct; auto. - simpl; rewrite B, C; eauto with asmgen. -- destruct (transl_cond_float c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. - set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (eqb normal b)). - { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_float c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. - assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). - { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } - set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (xorb normal b)). - { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_single c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. - set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (eqb normal b)). - { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. -- destruct (transl_cond_single c0 GPR31 x x0) as [insn normal] eqn:TC; inv EQ2. - assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). - { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } - set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). - assert (V: v = Val.of_bool (xorb normal b)). - { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } - econstructor; econstructor. - split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. +- exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + + constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + + split; auto. + * apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. + * intros. rewrite B'; eauto with asmgen. Qed. + Lemma transl_cbranch_correct_true: forall cond args lbl k c m ms sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -543,7 +451,7 @@ Proof. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. intros; Simpl. Qed. - +(* (** Translation of condition operators *) Lemma transl_cond_int32s_correct: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 280dd17b..2c7b8cc8 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -156,12 +156,36 @@ module Target : TARGET = | Ofsimm n -> ptrofs oc n | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) + let icond_name = function + | ITne | ITneu -> "ne" + | ITeq | ITequ -> "eq" + | ITlt -> "lt" + | ITge -> "ge" + | ITle -> "le" + | ITgt -> "gt" + | ITltu -> "ltu" + | ITgeu -> "geu" + | ITleu -> "leu" + | ITgtu -> "gtu" + | ITall -> "all" + | ITnall -> "nall" + | ITany -> "any" + | ITnone -> "none" + + let icond oc c = fprintf oc "%s" (icond_name c) + + let bcond_name = function + | BTwnez -> "wnez" + | BTweqz -> "weqz" + + let bcond oc c = fprintf oc "%s" (bcond_name c) + (* Printing of instructions *) let print_instruction oc = function | Pcall(s) -> fprintf oc " call %a\n;;\n" symbol s | Pgoto(s) | Pj_l(s) -> - fprintf oc " goto %a\n;;\n" symbol s + fprintf oc " goto %a\n;;\n" print_label s | Pret -> fprintf oc " ret\n;;\n" | Pget (rd, rs) -> @@ -171,352 +195,41 @@ module Target : TARGET = | Pmv(rd, rs) -> fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs - (* 32-bit integer register-immediate instructions *) | Paddiw (rd, rs, imm) -> fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - (*| Psltiw (rd, rs, imm) -> - fprintf oc " slti %a, %a, %a\n" ireg rd ireg rs coqint imm - | Psltiuw (rd, rs, imm) -> - fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg rs coqint imm - | Pandiw (rd, rs, imm) -> - fprintf oc " andi %a, %a, %a\n" ireg rd ireg rs coqint imm - | Poriw (rd, rs, imm) -> - fprintf oc " ori %a, %a, %a\n" ireg rd ireg rs coqint imm - | Pxoriw (rd, rs, imm) -> - fprintf oc " xori %a, %a, %a\n" ireg rd ireg rs coqint imm - | Pslliw (rd, rs, imm) -> - fprintf oc " slli%t %a, %a, %a\n" w ireg rd ireg rs coqint imm - | Psrliw (rd, rs, imm) -> - fprintf oc " srli%t %a, %a, %a\n" w ireg rd ireg rs coqint imm - | Psraiw (rd, rs, imm) -> - fprintf oc " srai%t %a, %a, %a\n" w ireg rd ireg rs coqint imm - | Pluiw (rd, imm) -> - fprintf oc " lui %a, %a\n" ireg rd coqint imm - - (* 32-bit integer register-register instructions *) - *)| Paddw(rd, rs1, rs2) -> + | Paddw(rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - (*| Psubw(rd, rs1, rs2) -> - fprintf oc " sub%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - - | Pmulw(rd, rs1, rs2) -> - fprintf oc " mul%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Pmulhw(rd, rs1, rs2) -> assert (not Archi.ptr64); - fprintf oc " mulh %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmulhuw(rd, rs1, rs2) -> assert (not Archi.ptr64); - fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pdivw(rd, rs1, rs2) -> - fprintf oc " div%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Pdivuw(rd, rs1, rs2) -> - fprintf oc " divu%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Premw(rd, rs1, rs2) -> - fprintf oc " rem%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Premuw(rd, rs1, rs2) -> - fprintf oc " remu%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - - | Psltw(rd, rs1, rs2) -> - fprintf oc " slt %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psltuw(rd, rs1, rs2) -> - fprintf oc " sltu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pandw(rd, rs1, rs2) -> - fprintf oc " and %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porw(rd, rs1, rs2) -> - fprintf oc " or %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorw(rd, rs1, rs2) -> - fprintf oc " xor %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psllw(rd, rs1, rs2) -> - fprintf oc " sll%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Psrlw(rd, rs1, rs2) -> - fprintf oc " srl%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - | Psraw(rd, rs1, rs2) -> - fprintf oc " sra%t %a, %a, %a\n" w ireg rd ireg rs1 ireg rs2 - - *)(* 64-bit integer register-immediate instructions *) | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - (*| Psltil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " slti %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Psltiul (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " sltiu %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andi %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ori %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xori %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Psllil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " slli %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Psrlil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " srli %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Psrail (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " srai %a, %a, %a\n" ireg rd ireg rs coqint64 imm - | Pluil (rd, imm) -> assert Archi.ptr64; - fprintf oc " lui %a, %a\n" ireg rd coqint64 imm - *) | Pmake (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm | Pmakel (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm - (* 64-bit integer register-register instructions *) | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - (*| Psubl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sub %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pmull(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mul %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmulhl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mulh %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmulhul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " mulhu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pdivl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " div %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pdivul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " divu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Preml(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " rem %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Premul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " remu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Psltl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " slt %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psltul(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sltu %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " and %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " or %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xor %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pslll(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sll %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psrll(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " srl %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psral(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " sra %a, %a, %a\n" ireg rd ireg rs1 ireg rs2 - - (* Unconditional jumps. Links are always to X1/RA. *) - (* TODO: fix up arguments for calls to variadics, to move *) - (* floating point arguments to integer registers. How? *) - | Pj_l(l) -> - fprintf oc " j %a\n" print_label l - | Pj_s(s, sg) -> - fprintf oc " j %a\n" symbol s - | Pj_r(r, sg) -> - fprintf oc " jr %a\n" ireg r - | Pjal_s(s, sg) -> - fprintf oc " call %a\n" symbol s - | Pjal_r(r, sg) -> - fprintf oc " jalr %a\n" ireg r - - (* Conditional branches, 32-bit comparisons *) - | Pbeqw(rs1, rs2, l) -> - fprintf oc " beq %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbnew(rs1, rs2, l) -> - fprintf oc " bne %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbltw(rs1, rs2, l) -> - fprintf oc " blt %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbltuw(rs1, rs2, l) -> - fprintf oc " bltu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbgew(rs1, rs2, l) -> - fprintf oc " bge %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbgeuw(rs1, rs2, l) -> - fprintf oc " bgeu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - - (* Conditional branches, 64-bit comparisons *) - | Pbeql(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " beq %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbnel(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bne %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbltl(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " blt %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbltul(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bltu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbgel(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bge %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - | Pbgeul(rs1, rs2, l) -> assert Archi.ptr64; - fprintf oc " bgeu %a, %a, %a\n" ireg rs1 ireg rs2 print_label l - - (* Loads and stores *) - | Plb(rd, ra, ofs) -> - fprintf oc " lb %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Plbu(rd, ra, ofs) -> - fprintf oc " lbu %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Plh(rd, ra, ofs) -> - fprintf oc " lh %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Plhu(rd, ra, ofs) -> - fprintf oc " lhu %a, %a(%a)\n" ireg rd offset ofs ireg ra - *)| Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra + + | Pcompw (it, rd, rs1, rs2) -> + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcb (bt, r, lbl) -> + fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + + | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> + fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - - (*| Psb(rd, ra, ofs) -> - fprintf oc " sb %a, %a(%a)\n" ireg rd offset ofs ireg ra - | Psh(rd, ra, ofs) -> - fprintf oc " sh %a, %a(%a)\n" ireg rd offset ofs ireg ra - *)| Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd + | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> + fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - - (* Synchronization *) - (*| Pfence -> - fprintf oc " fence\n" - - (* floating point register move. - fmv.d preserves single-precision register contents, and hence - is applicable to both single- and double-precision moves. - *) - | Pfmv (fd,fs) -> - fprintf oc " fmv.d %a, %a\n" freg fd freg fs - | Pfmvxs (rd,fs) -> - fprintf oc " fmv.x.s %a, %a\n" ireg rd freg fs - | Pfmvxd (rd,fs) -> - fprintf oc " fmv.x.d %a, %a\n" ireg rd freg fs - - (* 32-bit (single-precision) floating point *) - | Pfls (fd, ra, ofs) -> - fprintf oc " flw %a, %a(%a)\n" freg fd offset ofs ireg ra - | Pfss (fs, ra, ofs) -> - fprintf oc " fsw %a, %a(%a)\n" freg fs offset ofs ireg ra - - | Pfnegs (fd, fs) -> - fprintf oc " fneg.s %a, %a\n" freg fd freg fs - | Pfabss (fd, fs) -> - fprintf oc " fabs.s %a, %a\n" freg fd freg fs - - | Pfadds (fd, fs1, fs2) -> - fprintf oc " fadd.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfsubs (fd, fs1, fs2) -> - fprintf oc " fsub.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmuls (fd, fs1, fs2) -> - fprintf oc " fmul.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfdivs (fd, fs1, fs2) -> - fprintf oc " fdiv.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmins (fd, fs1, fs2) -> - fprintf oc " fmin.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmaxs (fd, fs1, fs2) -> - fprintf oc " fmax.s %a, %a, %a\n" freg fd freg fs1 freg fs2 - - | Pfeqs (rd, fs1, fs2) -> - fprintf oc " feq.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 - | Pflts (rd, fs1, fs2) -> - fprintf oc " flt.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 - | Pfles (rd, fs1, fs2) -> - fprintf oc " fle.s %a, %a, %a\n" ireg rd freg fs1 freg fs2 - - | Pfsqrts (fd, fs) -> - fprintf oc " fsqrt.s %a, %a\n" freg fd freg fs - - | Pfmadds (fd, fs1, fs2, fs3) -> - fprintf oc " fmadd.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfmsubs (fd, fs1, fs2, fs3) -> - fprintf oc " fmsub.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfnmadds (fd, fs1, fs2, fs3) -> - fprintf oc " fnmadd.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfnmsubs (fd, fs1, fs2, fs3) -> - fprintf oc " fnmsub.s %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - - | Pfcvtws (rd, fs) -> - fprintf oc " fcvt.w.s %a, %a, rtz\n" ireg rd freg fs - | Pfcvtwus (rd, fs) -> - fprintf oc " fcvt.wu.s %a, %a, rtz\n" ireg rd freg fs - | Pfcvtsw (fd, rs) -> - fprintf oc " fcvt.s.w %a, %a\n" freg fd ireg rs - | Pfcvtswu (fd, rs) -> - fprintf oc " fcvt.s.wu %a, %a\n" freg fd ireg rs - - | Pfcvtls (rd, fs) -> assert Archi.ptr64; - fprintf oc " fcvt.l.s %a, %a, rtz\n" ireg rd freg fs - | Pfcvtlus (rd, fs) -> assert Archi.ptr64; - fprintf oc " fcvt.lu.s %a, %a, rtz\n" ireg rd freg fs - | Pfcvtsl (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.s.l %a, %a\n" freg fd ireg rs - | Pfcvtslu (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.s.lu %a, %a\n" freg fd ireg rs - - (* 64-bit (double-precision) floating point *) - | Pfld (fd, ra, ofs) | Pfld_a (fd, ra, ofs) -> - fprintf oc " fld %a, %a(%a)\n" freg fd offset ofs ireg ra - | Pfsd (fs, ra, ofs) | Pfsd_a (fs, ra, ofs) -> - fprintf oc " fsd %a, %a(%a)\n" freg fs offset ofs ireg ra - - | Pfnegd (fd, fs) -> - fprintf oc " fneg.d %a, %a\n" freg fd freg fs - | Pfabsd (fd, fs) -> - fprintf oc " fabs.d %a, %a\n" freg fd freg fs - - | Pfaddd (fd, fs1, fs2) -> - fprintf oc " fadd.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfsubd (fd, fs1, fs2) -> - fprintf oc " fsub.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmuld (fd, fs1, fs2) -> - fprintf oc " fmul.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfdivd (fd, fs1, fs2) -> - fprintf oc " fdiv.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmind (fd, fs1, fs2) -> - fprintf oc " fmin.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - | Pfmaxd (fd, fs1, fs2) -> - fprintf oc " fmax.d %a, %a, %a\n" freg fd freg fs1 freg fs2 - - | Pfeqd (rd, fs1, fs2) -> - fprintf oc " feq.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 - | Pfltd (rd, fs1, fs2) -> - fprintf oc " flt.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 - | Pfled (rd, fs1, fs2) -> - fprintf oc " fle.d %a, %a, %a\n" ireg rd freg fs1 freg fs2 - - | Pfsqrtd (fd, fs) -> - fprintf oc " fsqrt.d %a, %a\n" freg fd freg fs - - | Pfmaddd (fd, fs1, fs2, fs3) -> - fprintf oc " fmadd.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfmsubd (fd, fs1, fs2, fs3) -> - fprintf oc " fmsub.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfnmaddd (fd, fs1, fs2, fs3) -> - fprintf oc " fnmadd.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - | Pfnmsubd (fd, fs1, fs2, fs3) -> - fprintf oc " fnmsub.d %a, %a, %a, %a\n" freg fd freg fs1 freg fs2 freg fs3 - - | Pfcvtwd (rd, fs) -> - fprintf oc " fcvt.w.d %a, %a, rtz\n" ireg rd freg fs - | Pfcvtwud (rd, fs) -> - fprintf oc " fcvt.wu.d %a, %a, rtz\n" ireg rd freg fs - | Pfcvtdw (fd, rs) -> - fprintf oc " fcvt.d.w %a, %a\n" freg fd ireg rs - | Pfcvtdwu (fd, rs) -> - fprintf oc " fcvt.d.wu %a, %a\n" freg fd ireg rs - - | Pfcvtld (rd, fs) -> assert Archi.ptr64; - fprintf oc " fcvt.l.d %a, %a, rtz\n" ireg rd freg fs - | Pfcvtlud (rd, fs) -> assert Archi.ptr64; - fprintf oc " fcvt.lu.d %a, %a, rtz\n" ireg rd freg fs - | Pfcvtdl (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.d.l %a, %a\n" freg fd ireg rs - | Pfcvtdlu (fd, rs) -> assert Archi.ptr64; - fprintf oc " fcvt.d.lu %a, %a\n" freg fd ireg rs - - | Pfcvtds (fd, fs) -> - fprintf oc " fcvt.d.s %a, %a\n" freg fd freg fs - | Pfcvtsd (fd, fs) -> - fprintf oc " fcvt.s.d %a, %a\n" freg fd freg fs - (* Pseudo-instructions expanded in Asmexpand *) - *)| Pallocframe(sz, ofs) -> + | Pallocframe(sz, ofs) -> assert false | Pfreeframe(sz, ofs) -> assert false - (*| Pseqw _ | Psnew _ | Pseql _ | Psnel _ | Pcvtl2w _ | Pcvtw2l _ -> - assert false (* Pseudo-instructions that remain *) - *)| Plabel lbl -> + | Plabel lbl -> fprintf oc "%a:\n" print_label lbl (*| Ploadsymbol(rd, id, ofs) -> loadsymbol oc rd id ofs -- cgit From 36076263491312d634bd0d39f8de718f32462da2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Apr 2018 11:40:16 +0200 Subject: MPPA - Added signed immediate comparison --- mppa_k1c/Asmgen.v | 6 +++--- mppa_k1c/Asmgenproof.v | 3 +++ mppa_k1c/Asmgenproof1.v | 12 ++++++++++++ 3 files changed, 18 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 4b249f91..bd65bab9 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -140,10 +140,10 @@ Definition transl_cbranch | Ccompu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_int32u c rd r1 r2 k) - | Ccompimm c n, a1 :: nil => +*)| Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (transl_condimm_int32s c rd r1 n k) - | Ccompl c, a1 :: a2 :: nil => + OK (loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k)) +(*| Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_int64s c rd r1 r2 k) | Ccomplu c, a1 :: a2 :: nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index dd495cd4..cc5383a0 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -180,6 +180,9 @@ Remark transl_cbranch_label: transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cbranch in H. (* unfold transl_cond_op in H. *) destruct cond; TailNoLabel. +(* Ccompimm *) + - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. +(* Ccompuimm *) - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. Qed. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index e16dbbaf..1d5a26c9 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -408,6 +408,18 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. +(* Ccompimm *) +- exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + + constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + + split; auto. + * apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. + * intros. rewrite B'; eauto with asmgen. +(* Ccompuimm *) - exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez GPR31 lbl). -- cgit From ca090744f399788a81f103206947d4d56cba9d87 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Apr 2018 13:58:10 +0200 Subject: MPPA - Added non immediate comparison --- mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/Asmgenproof.v | 6 +++++- mppa_k1c/Asmgenproof1.v | 12 ++++++++++++ 3 files changed, 21 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index bd65bab9..f1ff363d 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -134,13 +134,13 @@ Definition transl_cbranch | Ccompuimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k)) -(*| Ccomp c, a1 :: a2 :: nil => + | Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32s c rd r1 r2 k) + OK (transl_comp c Signed r1 r2 lbl k) | Ccompu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32u c rd r1 r2 k) -*)| Ccompimm c n, a1 :: nil => + OK (transl_comp c Unsigned r1 r2 lbl k) + | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k)) (*| Ccompl c, a1 :: a2 :: nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index cc5383a0..1e616a01 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -179,7 +179,11 @@ Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. - intros. unfold transl_cbranch in H. (* unfold transl_cond_op in H. *) destruct cond; TailNoLabel. + intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. +(* Ccomp *) + - unfold transl_comp; TailNoLabel. +(* Ccompu *) + - unfold transl_comp; TailNoLabel. (* Ccompimm *) - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. (* Ccompuimm *) diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 1d5a26c9..e83ef307 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -408,6 +408,18 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. +(* Ccomp *) +- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompu *) +- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. (* Ccompimm *) - exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). -- cgit From d72fcc2c96f665d0c7608797b1707f2d19daa892 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Apr 2018 16:01:32 +0200 Subject: MPPA - Long comparisons --- mppa_k1c/Asm.v | 29 ++++++++++- mppa_k1c/Asmgen.v | 20 ++++--- mppa_k1c/Asmgenproof.v | 8 +++ mppa_k1c/Asmgenproof1.v | 129 ++++++++++++++++++++++++++++++++++++++-------- mppa_k1c/TargetPrinter.ml | 2 + 5 files changed, 158 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d769062f..d19f9340 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -187,6 +187,7 @@ Inductive instruction : Type := (** Comparisons *) | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) + | Pcompd (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) @@ -602,6 +603,31 @@ Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := | ITnone => Vundef end. +Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := + let res := match t with + | ITne => Val.cmpl Cne v1 v2 + | ITeq => Val.cmpl Ceq v1 v2 + | ITlt => Val.cmpl Clt v1 v2 + | ITge => Val.cmpl Cge v1 v2 + | ITle => Val.cmpl Cle v1 v2 + | ITgt => Val.cmpl Cgt v1 v2 + | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Some Vundef + end in + match res with + | Some v => v + | None => Vundef + end + . + (** Execution of a single instruction [i] in initial state [rs] and [m]. Return updated state. For instructions that correspond to actual RISC-V instructions, the cases are straightforward @@ -637,8 +663,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Comparisons *) | Pcompw c d s1 s2 => - (* Next (nextinstr (rs#d <- (Val.cmp Cne rs##s1 rs##s2))) m *) Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m + | Pcompd c d s1 s2 => + Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m (** 32-bit integer register-immediate instructions *) | Paddiw d s i => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index f1ff363d..710bb32c 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -128,6 +128,10 @@ Definition transl_comp (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompw (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. +Definition transl_compl + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompd (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := match cond, args with @@ -143,19 +147,19 @@ Definition transl_cbranch | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k)) -(*| Ccompl c, a1 :: a2 :: nil => + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k)) + | Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64s c rd r1 r2 k) + OK (transl_compl c Signed r1 r2 lbl k) | Ccomplu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64u c rd r1 r2 k) + OK (transl_compl c Unsigned r1 r2 lbl k) | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (transl_condimm_int64s c rd r1 n k) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64u c rd r1 n k) - | Ccompf c, f1 :: f2 :: nil => + OK (loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k)) +(*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_float c rd r1 r2 in OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 1e616a01..3dce24cf 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -188,6 +188,14 @@ Proof. - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. (* Ccompuimm *) - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. +(* Ccompl *) + - unfold transl_compl; TailNoLabel. +(* Ccomplu *) + - unfold transl_compl; TailNoLabel. +(* Ccomplimm *) + - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. +(* Ccompluimm *) + - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. Qed. (* diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index e83ef307..fe037994 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -144,6 +144,22 @@ Proof. split. Simpl. intros; Simpl. Qed. + +Lemma loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + (* Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) @@ -194,28 +210,8 @@ Proof. split. Simpl. intros; Simpl. Qed. - -Lemma loadimm64_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int64.add_zero_l; Simpl. - intros; Simpl. -- exploit load_hilo64_correct; eauto. intros (rs' & A & B & C). - rewrite E. exists rs'; eauto. -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. *) + Lemma opimm64_correct: forall (op: ireg -> ireg -> ireg -> instruction) (opi: ireg -> ireg -> int64 -> instruction) @@ -390,6 +386,63 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compl_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_complu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', @@ -442,6 +495,40 @@ Proof. + split; auto. * apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. * intros. rewrite B'; eauto with asmgen. +(* Ccompl *) +- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplu *) +- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplimm *) +- exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + + constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + + split; auto. + * apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. + * intros. rewrite B'; eauto with asmgen. +(* Ccompluimm *) +- exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + + constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + + split; auto. + * apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. + * intros. rewrite B'; eauto with asmgen. Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 2c7b8cc8..2fafb127 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -210,6 +210,8 @@ module Target : TARGET = | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompd (it, rd, rs1, rs2) -> + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcb (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl -- cgit From be6796ea9e15f543606191bd6a26281ba37421ab Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 4 Apr 2018 16:57:50 +0200 Subject: MPPA - Desactivated Pbuiltin EF_annot --- mppa_k1c/TargetPrinter.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 2fafb127..ac6f8f1b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -266,17 +266,16 @@ module Target : TARGET = fprintf oc "%s end pseudoinstr btbl\n" comment *)| Pbuiltin(ef, args, res) -> begin match ef with - | EF_annot(kind,txt, targs) -> - let annot = + (*| EF_annot(kind,txt, targs) -> begin match (P.to_int kind) with - | 1 -> annot_text preg_annot "sp" (camlstring_of_coqstring txt) args + | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot | 2 -> let lbl = new_label () in fprintf oc "%a: " label lbl; - ais_annot_text lbl preg_annot "r1" (camlstring_of_coqstring txt) args + add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args | _ -> assert false - end in - fprintf oc "%s annotation: %S\n" comment annot - | EF_debug(kind, txt, targs) -> + end + *)| EF_debug(kind, txt, targs) -> print_debug_info comment print_file_line preg_annot "sp" oc (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> -- cgit From e20c07dddf528ce50951a59cb92f98b4bca8da77 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Apr 2018 13:55:44 +0200 Subject: MPPA - Optimized branch generation for word compare to 0 --- mppa_k1c/Asm.v | 31 +++++++++-- mppa_k1c/Asmgen.v | 29 +++++++++- mppa_k1c/Asmgenproof.v | 10 +++- mppa_k1c/Asmgenproof1.v | 134 ++++++++++++++++++++++++++++++++++++++-------- mppa_k1c/TargetPrinter.ml | 4 ++ 5 files changed, 178 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d19f9340..060cffd5 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -105,11 +105,11 @@ Inductive btest: Type := | BTeven (**r Even (LSB Clear) *) *)| BTwnez (**r Word Not Equal to Zero *) | BTweqz (**r Word Equal to Zero *) -(*| BTwltz (**r Word Less Than Zero *) + | BTwltz (**r Word Less Than Zero *) | BTwgez (**r Word Greater Than or Equal to Zero *) | BTwlez (**r Word Less Than or Equal to Zero *) | BTwgtz (**r Word Greater Than Zero *) -*). + . Inductive itest: Type := | ITne (**r Not Equal *) @@ -582,6 +582,27 @@ Definition itest_for_cmp (c: comparison) (s: signedness) := | Cgt, Unsigned => ITgtu end. +(* CoMParing Signed Words to Zero *) +Definition btest_for_cmpswz (c: comparison) := + match c with + | Cne => BTwnez + | Ceq => BTweqz + | Clt => BTwltz + | Cge => BTwgez + | Cle => BTwlez + | Cgt => BTwgtz + end. + +Definition cmp_for_btest (bt: btest) := + match bt with + | BTwnez => Some Cne + | BTweqz => Some Ceq + | BTwltz => Some Clt + | BTwgez => Some Cge + | BTwlez => Some Cle + | BTwgtz => Some Cgt + end. + (** Comparing integers *) Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := match t with @@ -693,9 +714,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Conditional branches *) | Pcb bt r l => - match bt with - | BTwnez => eval_branch f l rs m (Val.cmp_bool Cne rs##r (Vint (Int.repr 0))) - | _ => Stuck + match cmp_for_btest bt with + | Some c => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) + | None => Stuck end (* (** Conditional branches, 32-bit comparisons *) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 710bb32c..5ee86240 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -132,12 +132,33 @@ Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompd (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. +Definition select_comp (n: int) (c: comparison) : option comparison := + if Int.eq n Int.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compuimm + (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + match select_comp n c with + | Some Ceq => Pcb BTweqz r1 lbl :: k + | Some Cne => Pcb BTwnez r1 lbl :: k + | Some _ => nil (* Never happens *) + | None => loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k) + end + . + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := match cond, args with | Ccompuimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k)) + OK (transl_opt_compuimm n c r1 lbl k) | Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_comp c Signed r1 r2 lbl k) @@ -146,7 +167,11 @@ Definition transl_cbranch OK (transl_comp c Unsigned r1 r2 lbl k) | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k)) + OK (if Int.eq n Int.zero then + Pcb (btest_for_cmpswz c) r1 lbl :: k + else + loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k) + ) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k)) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 3dce24cf..e10290fd 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -185,9 +185,15 @@ Proof. (* Ccompu *) - unfold transl_comp; TailNoLabel. (* Ccompimm *) - - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. + - destruct (Int.eq n Int.zero); TailNoLabel. + unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. (* Ccompuimm *) - - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. + - unfold transl_opt_compuimm. + remember (select_comp n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; + destruct (Int.eq n Int.zero); destruct c0; discriminate. + + unfold loadimm32; + destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. (* Ccompl *) - unfold transl_compl; TailNoLabel. (* Ccomplu *) diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index fe037994..27b43c17 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -444,6 +444,77 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_opt_compuimm_correct: + forall n cmp r1 lbl k rs m b c, + select_comp n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 (Vint n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compuimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcb BTweqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. } + auto; + unfold eval_branch. unfold getw. rewrite EVAL'S; auto. + - (* c = Cne *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcb BTwnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (Val.cmp_bool Cne (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. } + auto; + unfold eval_branch. unfold getw. rewrite EVAL'S; auto. + - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. +Qed. + Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -474,27 +545,49 @@ Proof. + constructor. eexact A. + split; auto. apply C; auto. (* Ccompimm *) -- exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - + constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - + split; auto. - * apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. - * intros. rewrite B'; eauto with asmgen. +- remember (Int.eq n Int.zero) as eqz. + destruct eqz. + + assert (n = (Int.repr 0)). { + destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. + generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpswz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getw; rewrite EVAL'; auto. + + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } (* Ccompuimm *) -- exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - + constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - + split; auto. - * apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. - * intros. rewrite B'; eauto with asmgen. +- remember (select_comp n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compuimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } (* Ccompl *) - exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). exists rs', (Pcb BTwnez GPR31 lbl). @@ -531,7 +624,6 @@ Proof. * intros. rewrite B'; eauto with asmgen. Qed. - Lemma transl_cbranch_correct_true: forall cond args lbl k c m ms sp rs m', transl_cbranch cond args lbl k = OK c -> diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ac6f8f1b..72f6e12a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -177,6 +177,10 @@ module Target : TARGET = let bcond_name = function | BTwnez -> "wnez" | BTweqz -> "weqz" + | BTwltz -> "wltz" + | BTwgez -> "wgez" + | BTwlez -> "wlez" + | BTwgtz -> "wgtz" let bcond oc c = fprintf oc "%s" (bcond_name c) -- cgit From 1fecf8b3d07c09abd07aca2c20261e9d352e9527 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Apr 2018 16:02:01 +0200 Subject: MPPA - optimized branch generation for signed long compare to 0 --- mppa_k1c/Asm.v | 43 ++++++++++++++++++++++++++++++++----------- mppa_k1c/Asmgen.v | 6 +++++- mppa_k1c/Asmgenproof.v | 3 ++- mppa_k1c/Asmgenproof1.v | 34 ++++++++++++++++++++++++---------- mppa_k1c/TargetPrinter.ml | 6 ++++++ 5 files changed, 69 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 060cffd5..e1359cb0 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -95,13 +95,13 @@ Notation "'SP'" := GPR12 (only parsing) : asm. Notation "'RTMP'" := GPR31 (only parsing) : asm. Inductive btest: Type := -(*| BTdnez (**r Double Not Equal to Zero *) + | BTdnez (**r Double Not Equal to Zero *) | BTdeqz (**r Double Equal to Zero *) | BTdltz (**r Double Less Than Zero *) | 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) *) +(*| BTodd (**r Odd (LSB Set) *) | BTeven (**r Even (LSB Clear) *) *)| BTwnez (**r Word Not Equal to Zero *) | BTweqz (**r Word Equal to Zero *) @@ -566,6 +566,8 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti Inductive signedness: Type := Signed | Unsigned. +Inductive intsize: Type := Int | Long. + Definition itest_for_cmp (c: comparison) (s: signedness) := match c, s with | Cne, Signed => ITne @@ -582,7 +584,7 @@ Definition itest_for_cmp (c: comparison) (s: signedness) := | Cgt, Unsigned => ITgtu end. -(* CoMParing Signed Words to Zero *) +(* CoMPare Signed Words to Zero *) Definition btest_for_cmpswz (c: comparison) := match c with | Cne => BTwnez @@ -593,14 +595,32 @@ Definition btest_for_cmpswz (c: comparison) := | Cgt => BTwgtz end. +(* CoMPare Signed Doubles to Zero *) +Definition btest_for_cmpsdz (c: comparison) := + match c with + | Cne => BTdnez + | Ceq => BTdeqz + | Clt => BTdltz + | Cge => BTdgez + | Cle => BTdlez + | Cgt => BTdgtz + end. + Definition cmp_for_btest (bt: btest) := match bt with - | BTwnez => Some Cne - | BTweqz => Some Ceq - | BTwltz => Some Clt - | BTwgez => Some Cge - | BTwlez => Some Cle - | BTwgtz => Some Cgt + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTwltz => (Some Clt, Int) + | BTwgez => (Some Cge, Int) + | BTwlez => (Some Cle, Int) + | BTwgtz => (Some Cgt, Int) + + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | BTdltz => (Some Clt, Long) + | BTdgez => (Some Cge, Long) + | BTdlez => (Some Cle, Long) + | BTdgtz => (Some Cgt, Long) end. (** Comparing integers *) @@ -715,8 +735,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Conditional branches *) | Pcb bt r l => match cmp_for_btest bt with - | Some c => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) - | None => Stuck + | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0))) + | (None, _) => Stuck end (* (** Conditional branches, 32-bit comparisons *) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 5ee86240..4fed544f 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -183,7 +183,11 @@ Definition transl_cbranch OK (transl_compl c Unsigned r1 r2 lbl k) | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k)) + OK (if Int64.eq n Int64.zero then + Pcb (btest_for_cmpsdz c) r1 lbl :: k + else + loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k) + ) (*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_float c rd r1 r2 in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index e10290fd..a7a41f18 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -199,7 +199,8 @@ Proof. (* Ccomplu *) - unfold transl_compl; TailNoLabel. (* Ccomplimm *) - - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. + - destruct (Int64.eq n Int64.zero); TailNoLabel. + unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. (* Ccompluimm *) - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. Qed. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 27b43c17..aeee5e9e 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -601,16 +601,30 @@ Proof. + constructor. eexact A. + split; auto. apply C; auto. (* Ccomplimm *) -- exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - + constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - + split; auto. - * apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. - * intros. rewrite B'; eauto with asmgen. +- remember (Int64.eq n Int64.zero) as eqz. + destruct eqz. + + assert (n = (Int64.repr 0)). { + destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. + generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getl; rewrite EVAL'; auto. + + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } + (* Ccompluimm *) - exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 72f6e12a..dcae5b10 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -181,6 +181,12 @@ module Target : TARGET = | BTwgez -> "wgez" | BTwlez -> "wlez" | BTwgtz -> "wgtz" + | BTdnez -> "dnez" + | BTdeqz -> "deqz" + | BTdltz -> "dltz" + | BTdgez -> "dgez" + | BTdlez -> "dlez" + | BTdgtz -> "dgtz" let bcond oc c = fprintf oc "%s" (bcond_name c) -- cgit From 9862e89118492e6ab530b2e2992161dd4eb52d0a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Apr 2018 13:51:50 +0200 Subject: MPPA - Onegl + Pnegl --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmgen.v | 6 +++--- mppa_k1c/TargetPrinter.ml | 2 ++ 3 files changed, 8 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e1359cb0..568a88af 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -202,6 +202,7 @@ Inductive instruction : Type := (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) (* Unconditional jumps. Links are always to X1/RA. *) | Pj_l (l: label) (**r jump to label *) @@ -727,6 +728,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m + | Pnegl d s => + Next (nextinstr (rs#d <- (Val.negl rs###s))) m (** Unconditional jumps. *) | Pj_l l => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 4fed544f..1113bd4f 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -345,10 +345,10 @@ Definition transl_op | Oaddlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm64 rd rs n k) -(*| Onegl, a1 :: nil => + | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psubl rd GPR0 rs :: k) - | Osubl, a1 :: a2 :: nil => + OK (Pnegl rd rs :: k) +(*| Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubl rd rs1 rs2 :: k) | Omull, a1 :: a2 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index dcae5b10..cb978ba8 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -217,6 +217,8 @@ module Target : TARGET = fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pnegl(rd, rs) -> assert Archi.ptr64; + fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 -- cgit From e6fd7a6abcebee211acf1ef95e0779d7c8aa1325 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Apr 2018 13:59:34 +0200 Subject: MPPA - Oneg + Pnegw --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmgen.v | 6 +++--- mppa_k1c/TargetPrinter.ml | 2 ++ 3 files changed, 8 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 568a88af..d7959445 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -194,6 +194,7 @@ Inductive instruction : Type := (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) (** 64-bit integer register-immediate instructions *) | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) @@ -716,6 +717,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 32-bit integer register-register instructions *) | Paddw d s1 s2 => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m + | Pnegw d s => + Next (nextinstr (rs#d <- (Val.neg rs###s))) m (** 64-bit integer register-immediate instructions *) | Paddil d s i => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 1113bd4f..2c99b6dc 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -256,10 +256,10 @@ Definition transl_op | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm32 rd rs n k) -(*| Oneg, a1 :: nil => + | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psubw rd GPR0 rs :: k) - | Osub, a1 :: a2 :: nil => + OK (Pnegw rd rs :: 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 :: k) | Omul, a1 :: a2 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index cb978ba8..31a68e38 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -219,6 +219,8 @@ module Target : TARGET = fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pnegl(rd, rs) -> assert Archi.ptr64; fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs + | Pnegw(rd, rs) -> + fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 -- cgit From 67a5ffd5f8a1f2f95dc480daee9b5d927c768a2d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Apr 2018 15:18:50 +0200 Subject: MPPA - bunch of ops added : lowlong, and, or, shr.. --- mppa_k1c/Asm.v | 31 +++++++++++++++++++++++++++++++ mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/Asmgen.v | 34 +++++++++++++++++----------------- mppa_k1c/Asmgenproof.v | 6 ++++++ mppa_k1c/TargetPrinter.ml | 26 ++++++++++++++++++++++++-- 5 files changed, 80 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d7959445..6fe00407 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -191,18 +191,29 @@ Inductive instruction : Type := (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) + | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) + | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) (** 64-bit integer register-immediate instructions *) | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) + | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) + | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or long immediate *) + | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate long *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) +(** Conversions *) + | Pcvtl2w (rd: ireg) (rs: ireg) (**r Convert Long to Word *) + (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Pandl (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) + | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) (* Unconditional jumps. Links are always to X1/RA. *) @@ -713,16 +724,28 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 32-bit integer register-immediate instructions *) | Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m + | Pandiw d s i => + Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m + | Psrliw d s i => + Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m (** 32-bit integer register-register instructions *) | Paddw d s1 s2 => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m + | Pandw d s1 s2 => + Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m | Pnegw d s => Next (nextinstr (rs#d <- (Val.neg rs###s))) m (** 64-bit integer register-immediate instructions *) | Paddil d s i => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m + | Pandil d s i => + Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m + | Poril d s i => + Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m + | Psrlil d s i => + Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m | Pmakel d i => Next (nextinstr (rs#d <- (Vlong i))) m | Pmake d i => @@ -731,9 +754,17 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m + | Pandl d s1 s2 => + Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m + | Porl d s1 s2 => + Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m | Pnegl d s => Next (nextinstr (rs#d <- (Val.negl rs###s))) m +(** Conversions *) + | Pcvtl2w d s => + Next (nextinstr (rs#d <- (Val.loword rs###s))) m + (** Unconditional jumps. *) | Pj_l l => goto_label f l rs m diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index f21ad2eb..d24383a7 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -548,10 +548,10 @@ let expand_instruction instr = end else begin emit (Pxorl(rd, rs1, rs2)); emit (Psltul(rd, X0, X rd)) end - | Pcvtl2w(rd, rs) -> +*)| Pcvtl2w(rd, rs) -> assert Archi.ptr64; emit (Paddiw(rd, rs, Int.zero)) (* 32-bit sign extension *) - | Pcvtw2l(r) -> +(*| Pcvtw2l(r) -> assert Archi.ptr64 (* no-operation because the 32-bit integer was kept sign extended already *) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 2c99b6dc..b892cd64 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -82,8 +82,8 @@ Definition opimm32 (op: ireg -> ireg -> ireg -> instruction) end. Definition addimm32 := opimm32 Paddw Paddiw. -(* Definition andimm32 := opimm32 Pandw Pandiw. +(* Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition sltimm32 := opimm32 Psltw Psltiw. @@ -107,10 +107,10 @@ Definition opimm64 (op: ireg -> ireg -> ireg -> instruction) end. Definition addimm64 := opimm64 Paddl Paddil. +Definition orimm64 := opimm64 Porl Poril. +Definition andimm64 := opimm64 Pandl Pandil. (* -Definition andimm64 := opimm64 Pandl Pandil. -Definition orimm64 := opimm64 Porl Poril. Definition xorimm64 := opimm64 Pxorl Pxoril. Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. @@ -286,10 +286,10 @@ Definition transl_op | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 :: k) - | Oandimm n, a1 :: nil => +*)| Oandimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm32 rd rs n k) - | Oor, a1 :: a2 :: nil => +(*| Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 :: k) | Oorimm n, a1 :: nil => @@ -316,10 +316,10 @@ Definition transl_op | Oshru, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psrlw rd rs1 rs2 :: k) - | Oshruimm n, a1 :: nil => +*)| Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) - | Oshrximm n, a1 :: nil => +(*| Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else Psraiw GPR31 rs (Int.repr 31) :: @@ -328,10 +328,10 @@ Definition transl_op Psraiw rd GPR31 n :: k) (* [Omakelong], [Ohighlong] should not occur *) - | Olowlong, a1 :: nil => +*)| Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pcvtl2w rd rs :: k) - | Ocast32signed, a1 :: nil => +(*| Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: k) @@ -375,16 +375,16 @@ Definition transl_op | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 :: k) - | Oandlimm n, a1 :: nil => +*)| Oandlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm64 rd rs n k) - | Oorl, a1 :: a2 :: nil => +(*| Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 :: k) - | Oorlimm n, a1 :: nil => +*)| Oorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm64 rd rs n k) - | Oxorl, a1 :: a2 :: nil => +(*| Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 :: k) | Oxorlimm n, a1 :: nil => @@ -405,10 +405,10 @@ Definition transl_op | Oshrlu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psrll rd rs1 rs2 :: k) - | Oshrluimm n, a1 :: nil => +*)| Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n :: k) - | Oshrxlimm n, a1 :: nil => +(*| Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else Psrail GPR31 rs (Int.repr 63) :: @@ -656,9 +656,9 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) else loadind_ptr SP f.(fn_link_ofs) GPR30 c) *)| Mop op args res => transl_op op args res k -(*| Mload chunk addr args dst => + | Mload chunk addr args dst => transl_load chunk addr args dst k - | Mstore chunk addr args src => +(*| Mstore chunk addr args src => transl_store chunk addr args src k | Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index a7a41f18..c8a89ef3 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -307,8 +307,14 @@ Opaque Int.eq. - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. (* Oaddimm32 *) - apply opimm32_label; intros; exact I. +(* Oandimm32 *) +- apply opimm32_label; intros; exact I. (* Oaddimm64 *) - apply opimm64_label; intros; exact I. +(* Oandimm64 *) +- apply opimm64_label; intros; exact I. +(* Oorimm64 *) +- apply opimm64_label; intros; exact I. Qed. (* diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 31a68e38..af76fdfc 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -211,12 +211,33 @@ module Target : TARGET = fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Psrliw (rd, rs, imm) -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrlil (rd, rs, imm) -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + + | Poril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Porl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Pandiw (rd, rs, imm) -> + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandw(rd, rs1, rs2) -> + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pmake (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm | Pmakel (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm - | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pnegl(rd, rs) -> assert Archi.ptr64; fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs | Pnegw(rd, rs) -> @@ -243,6 +264,7 @@ module Target : TARGET = assert false | Pfreeframe(sz, ofs) -> assert false + | Pcvtl2w _ -> assert false (* Pseudo-instructions that remain *) | Plabel lbl -> -- cgit From 8bdfa912a9ba8cee569cb40bf2ec4c584095e402 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 10 Apr 2018 17:22:34 +0200 Subject: MPPA - Added Mload --- mppa_k1c/Asm.v | 23 ++++++++++++++--------- mppa_k1c/Asmgen.v | 10 +++++----- mppa_k1c/Asmgenproof.v | 7 +++++-- mppa_k1c/Asmgenproof1.v | 17 ++++++++++++++--- mppa_k1c/TargetPrinter.ml | 29 +++++++++++++++++++---------- 5 files changed, 57 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 6fe00407..b988a156 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -222,11 +222,16 @@ Inductive instruction : Type := (* Conditional branches *) | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) + | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) + | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) + | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *) | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) - + | Psb (rd: ireg) (ra: ireg) (ofs: offset) (**r store byte *) + | Psh (rd: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) @@ -319,8 +324,8 @@ Inductive instruction : Type := | 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 *) - | Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) +(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) @@ -806,7 +811,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Cge rs###s1 rs###s2) (** Loads and stores *) - | Plb d a ofs => +*)| Plb d a ofs => exec_load Mint8signed rs m d a ofs | Plbu d a ofs => exec_load Mint8unsigned rs m d a ofs @@ -814,7 +819,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mint16signed rs m d a ofs | Plhu d a ofs => exec_load Mint16unsigned rs m d a ofs -*)| Plw d a ofs => + | Plw d a ofs => exec_load Mint32 rs m d a ofs | Plw_a d a ofs => exec_load Many32 rs m d a ofs @@ -822,11 +827,11 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mint64 rs m d a ofs | Pld_a d a ofs => exec_load Many64 rs m d a ofs -(*| Psb s a ofs => + | Psb s a ofs => exec_store Mint8unsigned rs m s a ofs | Psh s a ofs => exec_store Mint16unsigned rs m s a ofs -*)| Psw s a ofs => + | Psw s a ofs => exec_store Mint32 rs m s a ofs | Psw_a s a ofs => exec_store Many32 rs m s a ofs @@ -959,9 +964,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Plabel lbl => Next (nextinstr rs) m -(*| Ploadsymbol rd s ofs => + | Ploadsymbol rd s ofs => Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m - | Ploadsymbol_high rd s ofs => +(*| Ploadsymbol_high rd s ofs => Next (nextinstr (rs#rd <- (high_half ge s ofs))) m | Ploadli rd i => Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index b892cd64..874ef101 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -567,21 +567,21 @@ Definition transl_memory_access (mk_instr: ireg -> offset -> instruction) (addr: addressing) (args: list mreg) (k: code) : res (list instruction) := match addr, args with -(*| Aindexed ofs, a1 :: nil => + | Aindexed ofs, a1 :: nil => do rs <- ireg_of a1; OK (indexed_memory_access mk_instr rs ofs k) | Aglobal id ofs, nil => - OK (Ploadsymbol_high GPR31 id ofs :: mk_instr GPR31 (Ofslow id ofs) :: k) + OK (Ploadsymbol GPR31 id ofs :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k) | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs k) -*)| _, _ => + | _, _ => Error(msg "Asmgen.transl_memory_access") end. Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: code) : res (list instruction) := match chunk with -(*| Mint8signed => + | Mint8signed => do r <- ireg_of dst; transl_memory_access (Plb r) addr args k | Mint8unsigned => @@ -605,7 +605,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) | Mfloat64 => do r <- freg_of dst; transl_memory_access (Pfld r) addr args k -*)| _ => + | _ => Error (msg "Asmgen.transl_load") end. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index c8a89ef3..d8080257 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -401,7 +401,10 @@ Proof. - eapply loadind_label; eauto. (* storeind *) - eapply storeind_label; eauto. +(* transl_op *) - eapply transl_op_label; eauto. +(* transl_load *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans ; [eapply make_epilogue_label|TailNoLabel]. @@ -776,13 +779,13 @@ Local Transparent destroyed_by_op. exploit Mem.loadv_extends; eauto. intros [v' [C D]]. left; eapply exec_straight_steps; eauto; intros. simpl in TR. inversion TR. -(*exploit transl_load_correct; eauto. + exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. exists rs2; split. eauto. split. eapply agree_set_undef_mreg; eauto. congruence. intros; auto with asmgen. simpl; congruence. -*) + - (* Mstore *) assert (eval_addressing tge sp addr (map rs args) = Some a). diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index aeee5e9e..55724239 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1431,16 +1431,27 @@ Lemma transl_memory_access_correct: Proof. intros until v; intros TR EV. unfold transl_memory_access in TR; destruct addr; ArgsInv. -(* - (* indexed *) inv EV. apply indexed_memory_access_correct; eauto with asmgen. - (* global *) simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. constructor. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. unfold eval_offset. apply low_high_half. + split; intros; Simpl. unfold eval_offset. + assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). + { apply Val.offset_ptr_zero. } + remember (Genv.symbol_address ge i i0) as symbol. + destruct symbol; auto. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + simpl. rewrite Ptrofs.add_zero; auto. - (* stack *) inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. -*) Qed. Lemma transl_load_access_correct: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index af76fdfc..e93603a4 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -124,17 +124,14 @@ module Target : TARGET = (* Generate code to load the address of id + ofs in register r *) - (*let loadsymbol oc r id ofs = + let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); - fprintf oc " la %a, %s\n" ireg r (extern_atom id) + fprintf oc " make %a = %s\n;;\n" ireg r (extern_atom id) end else begin - fprintf oc " lui %a, %%hi(%a)\n" - ireg r symbol_offset (id, ofs); - fprintf oc " addi %a, %a, %%lo(%a)\n" - ireg r ireg r symbol_offset (id, ofs) + fprintf oc " make %a = %a\n;;\n" ireg r symbol_offset (id, ofs) end - *) + (* Emit .file / .loc debugging directives *) let print_file_line oc file line = @@ -250,10 +247,22 @@ module Target : TARGET = | Pcb (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + | Plb(rd, ra, ofs) -> + fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plbu(rd, ra, ofs) -> + fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plh(rd, ra, ofs) -> + fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plhu(rd, ra, ofs) -> + fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Psb(rd, ra, ofs) -> + fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psh(rd, ra, ofs) -> + fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; @@ -269,10 +278,10 @@ module Target : TARGET = (* Pseudo-instructions that remain *) | Plabel lbl -> fprintf oc "%a:\n" print_label lbl - (*| Ploadsymbol(rd, id, ofs) -> + | Ploadsymbol(rd, id, ofs) -> loadsymbol oc rd id ofs - | Ploadsymbol_high(rd, id, ofs) -> - fprintf oc " lui %a, %%hi(%a)\n" ireg rd symbol_offset (id, ofs) + (*| Ploadsymbol_high(rd, id, ofs) -> + fprintf oc " lui %a, %%hi[%a]\n" ireg rd symbol_offset (id, ofs) | Ploadli(rd, n) -> let d = camlint64_of_coqint n in let lbl = label_literal64 d in -- cgit From 89a54eee40305a61d1c1c0b9c5e6ba039592507b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Apr 2018 10:53:48 +0200 Subject: MPPA - Onegf --- mppa_k1c/Asm.v | 8 ++++---- mppa_k1c/Asmgen.v | 12 ++++++------ mppa_k1c/Asmgenproof.v | 6 ++++-- mppa_k1c/Asmgenproof1.v | 2 -- mppa_k1c/TargetPrinter.ml | 3 +++ 5 files changed, 17 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b988a156..db2f9ee2 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -286,8 +286,8 @@ Inductive instruction : Type := *)| Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) (*| Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) - | Pfnegd (rd: freg) (rs: freg) (**r negation *) - | Pfabsd (rd: freg) (rs: freg) (**r absolute value *) +*)| Pfnegd (rd: freg) (rs: freg) (**r negation *) +(*| Pfabsd (rd: freg) (rs: freg) (**r absolute value *) | Pfaddd (rd: freg) (rs1 rs2: freg) (**r addition *) | Pfsubd (rd: freg) (rs1 rs2: freg) (**r subtraction *) @@ -898,9 +898,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (*| Pfsd_a s a ofs => exec_store Many64 rs m s a ofs - | Pfnegd d s => +*)| Pfnegd d s => Next (nextinstr (rs#d <- (Val.negf rs#s))) m - | Pfabsd d s => +(*| Pfabsd d s => Next (nextinstr (rs#d <- (Val.absf rs#s))) m | Pfaddd d s1 s2 => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 874ef101..9a4c2ba3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -416,10 +416,10 @@ Definition transl_op Paddl GPR31 rs GPR31 :: Psrail rd GPR31 n :: k) - | Onegf, a1 :: nil => +*)| Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs :: k) - | Oabsf, a1 :: nil => +(*| Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs :: k) | Oaddf, a1 :: a2 :: nil => @@ -612,7 +612,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) Definition transl_store (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) (k: code) : res (list instruction) := match chunk with -(*| Mint8signed | Mint8unsigned => + | Mint8signed | Mint8unsigned => do r <- ireg_of src; transl_memory_access (Psb r) addr args k | Mint16signed | Mint16unsigned => @@ -630,7 +630,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) | Mfloat64 => do r <- freg_of src; transl_memory_access (Pfsd r) addr args k -*)| _ => + | _ => Error (msg "Asmgen.transl_store") end. @@ -658,9 +658,9 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) transl_op op args res k | Mload chunk addr args dst => transl_load chunk addr args dst k -(*| Mstore chunk addr args src => + | Mstore chunk addr args src => transl_store chunk addr args src k - | Mcall sig (inl r) => +(*| Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) *)| Mcall sig (inr symb) => OK ((Pcall symb) :: k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index d8080257..4809afcb 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -405,6 +405,8 @@ Proof. - eapply transl_op_label; eauto. (* transl_load *) - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +(* transl store *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct s0; monadInv H; TailNoLabel. - destruct s0; monadInv H; eapply tail_nolabel_trans ; [eapply make_epilogue_label|TailNoLabel]. @@ -797,11 +799,11 @@ Local Transparent destroyed_by_op. left; eapply exec_straight_steps; eauto. intros. simpl in TR. inversion TR. -(*exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. exists rs2; split. eauto. split. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -*) + - (* Mcall *) assert (f0 = f) by congruence. subst f0. inv AT. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 55724239..e5d5af55 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1534,10 +1534,8 @@ Proof. /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). { unfold transl_store in TR; destruct chunk; ArgsInv; (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). -(* destruct a; auto. apply Mem.store_signed_unsigned_8. destruct a; auto. apply Mem.store_signed_unsigned_16. -*) } destruct A as (mk_instr & chunk' & B & C & D). rewrite D in STORE; clear D. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index e93603a4..16d75df3 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -268,6 +268,9 @@ module Target : TARGET = | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Pfnegd(rd, ra) -> + fprintf oc " fnegd %a = %a\n;;\n" ireg ra ireg rd + (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, ofs) -> assert false -- cgit From a6c79438ae754d969558bd37eb3a7676be6e66aa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Apr 2018 15:26:03 +0200 Subject: MPPA - Ocast32signed --- mppa_k1c/Asm.v | 6 ++++++ mppa_k1c/Asmexpand.ml | 5 +++-- mppa_k1c/Asmgen.v | 13 +++++++++---- mppa_k1c/Asmgenproof.v | 7 +++++++ mppa_k1c/Asmgenproof1.v | 26 ++++++++++++++++++++++++++ mppa_k1c/TargetPrinter.ml | 4 ++-- 6 files changed, 53 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index db2f9ee2..d7007102 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -209,6 +209,8 @@ Inductive instruction : Type := (** Conversions *) | Pcvtl2w (rd: ireg) (rs: ireg) (**r Convert Long to Word *) + | Pcvtw2l (r : ireg) (**r Convert Word to Long *) + | Pmvw2l (rd: ireg) (rs: ireg) (**r Move Convert Word to Long *) (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) @@ -769,6 +771,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Conversions *) | Pcvtl2w d s => Next (nextinstr (rs#d <- (Val.loword rs###s))) m + | Pcvtw2l r => + Next (nextinstr (rs#r <- (Val.longofint rs#r))) m + | Pmvw2l d s => + Next (nextinstr (rs#d <- (Val.longofint rs#s))) m (** Unconditional jumps. *) | Pj_l l => diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d24383a7..51d63da5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -551,11 +551,12 @@ let expand_instruction instr = *)| Pcvtl2w(rd, rs) -> assert Archi.ptr64; emit (Paddiw(rd, rs, Int.zero)) (* 32-bit sign extension *) -(*| Pcvtw2l(r) -> + | Pcvtw2l(r) -> assert Archi.ptr64 (* no-operation because the 32-bit integer was kept sign extended already *) + (* FIXME - is it really the case on the MPPA ? *) - | Pjal_r(r, sg) -> +(*| Pjal_r(r, sg) -> fixup_call sg; emit instr | Pjal_s(symb, sg) -> fixup_call sg; emit instr diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 9a4c2ba3..828073f7 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -116,6 +116,12 @@ Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. *) +Definition cast32signed (rd rs: ireg) (k: code) := + if (ireg_eq rd rs) + then Pcvtw2l rd :: k + else Pmvw2l rd rs :: k + . + Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then Pmv rd rs :: k @@ -331,11 +337,10 @@ Definition transl_op *)| Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pcvtl2w rd rs :: k) -(*| Ocast32signed, a1 :: nil => + | Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - assertion (ireg_eq rd rs); - OK (Pcvtw2l rd :: k) - | Ocast32unsigned, a1 :: nil => + OK (cast32signed rd rs k) +(*| Ocast32unsigned, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 4809afcb..905bb85c 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -142,6 +142,13 @@ Proof. Qed. Hint Resolve loadimm64_label: labels. +Remark cast32signed_label: + forall rd rs k, tail_nolabel k (cast32signed rd rs k). +Proof. + intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. +Qed. +Hint Resolve cast32signed_label: labels. + Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index e5d5af55..ef70cec4 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1080,6 +1080,26 @@ Proof. 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 fn (cast32signed d s 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. Simpl. + + split. + * rewrite e. Simpl. + * intros. destruct r; Simpl. +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. Simpl. + + split. + * Simpl. + * intros. destruct r; Simpl. +Qed. + (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -1109,6 +1129,11 @@ Opaque Int.eq. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. - (* move *) destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Ocast32signed *) + exploit cast32signed_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. split. apply B. + intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } + apply C; auto. (* - (* intconst *) exploit loadimm32_correct; eauto. intros (rs' & A & B & C). @@ -1233,6 +1258,7 @@ Opaque Int.eq. *) Qed. + (** Memory accesses *) Lemma indexed_memory_access_correct: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 16d75df3..3e4c3ff6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -199,7 +199,7 @@ module Target : TARGET = fprintf oc " get %a = %a\n;;\n" ireg rd preg rs | Pset (rd, rs) -> fprintf oc " set %a = %a\n;;\n" preg rd ireg rs - | Pmv(rd, rs) -> + | Pmv(rd, rs) | Pmvw2l(rd, rs) -> fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs | Paddiw (rd, rs, imm) -> @@ -276,7 +276,7 @@ module Target : TARGET = assert false | Pfreeframe(sz, ofs) -> assert false - | Pcvtl2w _ -> assert false + | Pcvtl2w _ | Pcvtw2l _ -> assert false (* Pseudo-instructions that remain *) | Plabel lbl -> -- cgit From 1ecd47e848d3073c7317dc39c4fa72dbac66dd60 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Apr 2018 15:35:01 +0200 Subject: MPPA - Oshr --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/TargetPrinter.ml | 2 ++ 3 files changed, 7 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d7007102..c2f145aa 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -193,6 +193,7 @@ Inductive instruction : Type := | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) + | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) @@ -743,6 +744,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m | Pnegw d s => Next (nextinstr (rs#d <- (Val.neg rs###s))) m + | Psraw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m (** 64-bit integer register-immediate instructions *) | Paddil d s i => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 828073f7..f3fccca8 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -313,10 +313,10 @@ Definition transl_op | Oshlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs n :: k) - | Oshr, a1 :: a2 :: nil => +*)| Oshr, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psraw rd rs1 rs2 :: k) - | Oshrimm n, a1 :: nil => +(*| Oshrimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psraiw rd rs n :: k) | Oshru, a1 :: a2 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3e4c3ff6..00129c97 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -215,6 +215,8 @@ module Target : TARGET = fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psraw (rd, rs1, rs2) -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm -- cgit From 9fd4e33a6dd2c2dc88103711af62a7214dbd4109 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 11 Apr 2018 17:13:41 +0200 Subject: Osub and Omul --- mppa_k1c/Asm.v | 6 ++++++ mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/TargetPrinter.ml | 6 ++++++ 3 files changed, 14 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index c2f145aa..72bbff69 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -197,6 +197,8 @@ Inductive instruction : Type := (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subition *) + | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer mulition *) | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) @@ -740,6 +742,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 32-bit integer register-register instructions *) | Paddw d s1 s2 => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m + | Psubw d s1 s2 => + Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m + | Pmulw d s1 s2 => + Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m | Pandw d s1 s2 => Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m | Pnegw d s => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index f3fccca8..3984c43f 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -265,13 +265,13 @@ Definition transl_op | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs :: k) -(*| Osub, a1 :: a2 :: nil => + | Osub, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubw rd rs1 rs2 :: 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 :: k) - | Omulhs, a1 :: a2 :: nil => +(*| Omulhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhw rd rs1 rs2 :: k) | Omulhu, a1 :: a2 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 00129c97..ca26dbbe 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -211,6 +211,12 @@ module Target : TARGET = | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubw(rd, rs1, rs2) -> + fprintf oc " sbfwd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Pmulw(rd, rs1, rs2) -> + fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrliw (rd, rs, imm) -> fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> -- cgit From 0ef341c554aff8d70f879411bb0918fb8349f2e4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Apr 2018 16:05:42 +0200 Subject: MPPA - Added optim for long unsigned cmp to 0. --- mppa_k1c/Asm.v | 16 +++++++ mppa_k1c/Asmgen.v | 27 +++++++++-- mppa_k1c/Asmgenproof.v | 7 ++- mppa_k1c/Asmgenproof1.v | 111 ++++++++++++++++++++++++++++++++++++++-------- mppa_k1c/TargetPrinter.ml | 2 +- 5 files changed, 140 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 72bbff69..bc8c07e4 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -226,6 +226,7 @@ Inductive instruction : Type := (* Conditional branches *) | 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 *) | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) @@ -646,6 +647,15 @@ Definition cmp_for_btest (bt: btest) := | BTdgtz => (Some Cgt, Long) end. +Definition cmpu_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | _ => (None, Int) + end. + (** Comparing integers *) Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := match t with @@ -796,6 +806,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0))) | (None, _) => Stuck end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs##r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs###r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end (* (** Conditional branches, 32-bit comparisons *) | Pbeqw s1 s2 l => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 3984c43f..0f0d3e41 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -152,13 +152,34 @@ Definition select_comp (n: int) (c: comparison) : option comparison := Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_comp n c with - | Some Ceq => Pcb BTweqz r1 lbl :: k - | Some Cne => Pcb BTwnez r1 lbl :: k + | Some Ceq => Pcbu BTweqz r1 lbl :: k + | Some Cne => Pcbu BTwnez r1 lbl :: k | Some _ => nil (* Never happens *) | None => loadimm32 RTMP n (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 + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compluimm + (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + match select_compl n c with + | Some Ceq => Pcbu BTdeqz r1 lbl :: k + | Some Cne => Pcbu BTdnez r1 lbl :: k + | Some _ => nil (* Never happens *) + | None => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k) + end + . + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := match cond, args with @@ -180,7 +201,7 @@ Definition transl_cbranch ) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k)) + OK (transl_opt_compluimm n c r1 lbl k) | Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_compl c Signed r1 r2 lbl k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 905bb85c..60616311 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -209,7 +209,12 @@ Proof. - destruct (Int64.eq n Int64.zero); TailNoLabel. unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. (* Ccompluimm *) - - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. + - unfold transl_opt_compluimm. + remember (select_compl n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; + destruct (Int64.eq n Int64.zero); destruct c0; discriminate. + + unfold loadimm64; + destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. Qed. (* diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index ef70cec4..62c3bb49 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -474,14 +474,15 @@ Proof. intros; contradict H; discriminate. } - exists rs, (Pcb BTweqz r1 lbl). + exists rs, (Pcbu BTweqz r1 lbl). split. * constructor. * split; auto. simpl. intros. - assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. - { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. } + (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) auto; - unfold eval_branch. unfold getw. rewrite EVAL'S; auto. + unfold eval_branch. unfold getw. rewrite H0 in H2. unfold getw in H2. + rewrite H1. rewrite H2; auto. - (* c = Cne *) assert (Int.eq n Int.zero = true) as H'. { remember (Int.eq n Int.zero) as termz. destruct termz; auto. @@ -497,14 +498,12 @@ Proof. rewrite H'; simpl; auto; intros; contradict H; discriminate. } - exists rs, (Pcb BTwnez r1 lbl). + exists rs, (Pcbu BTwnez r1 lbl). split. * constructor. * split; auto. simpl. intros. - assert (Val.cmp_bool Cne (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. - { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. } auto; - unfold eval_branch. unfold getw. rewrite EVAL'S; auto. + unfold eval_branch. rewrite <- H0. rewrite H1. rewrite H2. auto. - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); destruct cmp; discriminate. - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); @@ -515,6 +514,73 @@ Proof. destruct cmp; discriminate. Qed. +Lemma transl_opt_compluimm_correct: + forall n cmp r1 lbl k rs m b c, + select_compl n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 (Vlong n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compluimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcbu BTdeqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Cne *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcbu BTdnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. +Qed. + Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -626,16 +692,25 @@ Proof. { intros. rewrite B'; eauto with asmgen. } (* Ccompluimm *) -- exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - + constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - + split; auto. - * apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. - * intros. rewrite B'; eauto with asmgen. +- remember (select_compl n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compluimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } Qed. Lemma transl_cbranch_correct_true: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ca26dbbe..af7b7b30 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -252,7 +252,7 @@ module Target : TARGET = fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompd (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcb (bt, r, lbl) -> + | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl | Plb(rd, ra, ofs) -> -- cgit From 3997c0bc61ddbbceefd449a8007e7212add8ac4a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 17 Apr 2018 16:30:26 +0200 Subject: MPPA - added all shifts --- mppa_k1c/Asm.v | 17 ++++++++++++++++- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/TargetPrinter.ml | 10 ++++++++++ 3 files changed, 28 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index bc8c07e4..f11a8cbe 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -193,7 +193,6 @@ Inductive instruction : Type := | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) - | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) @@ -201,12 +200,15 @@ Inductive instruction : Type := | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer mulition *) | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) + | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) (** 64-bit integer register-immediate instructions *) | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or long immediate *) + | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate long *) | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) @@ -220,6 +222,9 @@ Inductive instruction : Type := | Pandl (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) + | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic long *) (* Unconditional jumps. Links are always to X1/RA. *) | Pj_l (l: label) (**r jump to label *) @@ -770,8 +775,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m | Poril d s i => Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m + | Psllil d s i => + Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m | Psrlil d s i => Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m + | Psrail d s i => + Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m | Pmakel d i => Next (nextinstr (rs#d <- (Vlong i))) m | Pmake d i => @@ -786,6 +795,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m | Pnegl d s => Next (nextinstr (rs#d <- (Val.negl rs###s))) m + | Pslll d s1 s2 => + Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m + | Psrll d s1 s2 => + Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m + | Psral d s1 s2 => + Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m (** Conversions *) | Pcvtl2w d s => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 0f0d3e41..12cdb114 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -416,7 +416,7 @@ Definition transl_op | Oxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm64 rd rs n k) - | Oshll, a1 :: a2 :: nil => +*)| Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 :: k) | Oshllimm n, a1 :: nil => @@ -431,7 +431,7 @@ Definition transl_op | Oshrlu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psrll rd rs1 rs2 :: k) -*)| Oshrluimm n, a1 :: nil => + | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n :: k) (*| Oshrxlimm n, a1 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index af7b7b30..0f242eda 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -221,8 +221,18 @@ module Target : TARGET = fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrll (rd, rs1, rs2) -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psllil (rd, rs, imm) -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pslll (rd, rs1, rs2) -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psral (rd, rs1, rs2) -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrail (rd, rs1, imm) -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm -- cgit From b63085295d8495ff640f5eaff8b8ad52fc5c43d1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 17 Apr 2018 17:03:52 +0200 Subject: MPPA - More shifts --- mppa_k1c/Asm.v | 12 ++++++++++++ mppa_k1c/Asmgen.v | 8 ++++---- mppa_k1c/TargetPrinter.ml | 8 ++++++++ 3 files changed, 24 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f11a8cbe..b2272f7a 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -192,7 +192,9 @@ Inductive instruction : Type := (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) + | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate *) | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) + | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate *) (** 32-bit integer register-register instructions *) | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) @@ -201,6 +203,8 @@ Inductive instruction : Type := | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) + | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift right logical *) + | Psllw (rd: ireg) (rs1 rs2: ireg) (**r shift left logical word *) (** 64-bit integer register-immediate instructions *) | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) @@ -751,8 +755,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m | Pandiw d s i => Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m + | Psraiw d s i => + Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m | Psrliw d s i => Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m + | Pslliw d s i => + Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m (** 32-bit integer register-register instructions *) | Paddw d s1 s2 => @@ -765,8 +773,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m | Pnegw d s => Next (nextinstr (rs#d <- (Val.neg rs###s))) m + | Psrlw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m | Psraw d s1 s2 => Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m + | Psllw d s1 s2 => + Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m (** 64-bit integer register-immediate instructions *) | Paddil d s i => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 12cdb114..98253ab3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -328,22 +328,22 @@ Definition transl_op | Oxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm32 rd rs n k) - | Oshl, a1 :: a2 :: nil => +*)| Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 :: k) | Oshlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs n :: k) -*)| Oshr, a1 :: a2 :: nil => + | Oshr, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psraw rd rs1 rs2 :: k) -(*| Oshrimm n, a1 :: nil => + | Oshrimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psraiw rd rs n :: k) | Oshru, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psrlw rd rs1 rs2 :: k) -*)| Oshruimm n, a1 :: nil => + | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) (*| Oshrximm n, a1 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 0f242eda..977d3019 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -223,12 +223,20 @@ module Target : TARGET = fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrll (rd, rs1, rs2) -> fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrlw (rd, rs1, rs2) -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pslliw (rd, rs, imm) -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psllw (rd, rs1, rs2) -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psllil (rd, rs, imm) -> fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pslll (rd, rs1, rs2) -> fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psraiw (rd, rs1, imm) -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 coqint64 imm | Psral (rd, rs1, rs2) -> fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psrail (rd, rs1, imm) -> -- cgit From 139595171a98e6722503202a2a8fb7c000f267c2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Apr 2018 18:06:30 +0200 Subject: MPPA - added Oaddrstack - problem in TargetPrinter.ml Pbuiltin EF_annot Conflicts: mppa_k1c/Asmgenproof1.v --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 6 +++--- mppa_k1c/Asmgenproof1.v | 19 ++++++++----------- mppa_k1c/TargetPrinter.ml | 20 ++++++++++---------- 4 files changed, 23 insertions(+), 26 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 98253ab3..9025a00d 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -267,11 +267,11 @@ Definition transl_op OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) then Ploadsymbol rd s Ptrofs.zero :: addptrofs rd rd ofs k else Ploadsymbol rd s ofs :: k) - | Oaddrstack n, nil => +*)| Oaddrstack n, nil => do rd <- ireg_of res; OK (addptrofs rd SP n k) - | Ocast8signed, a1 :: nil => +(*| Ocast8signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) | Ocast16signed, a1 :: nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 60616311..4150cba8 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -159,15 +159,15 @@ Proof. (*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) Qed. Hint Resolve opimm64_label: labels. -(* + Remark addptrofs_label: forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). Proof. unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. - destruct Archi.ptr64. apply opimm64_label; TailNoLabel. apply opimm32_label; TailNoLabel. + apply opimm64_label; TailNoLabel. Qed. Hint Resolve addptrofs_label: labels. - +(* Remark transl_cond_float_nolabel: forall c r1 r2 r3 insn normal, transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 62c3bb49..77643b8b 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -247,7 +247,7 @@ Proof. Qed. (** Add offset to pointer *) -(* + Lemma addptrofs_correct: forall rd r1 n k rs m, r1 <> GPR31 -> @@ -262,19 +262,13 @@ Proof. apply exec_straight_one. simpl; eauto. auto. split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. intros; Simpl. -- destruct Archi.ptr64 eqn:SF. -+ unfold addimm64. +- unfold addimm64. exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. split; auto. - rewrite B. simpl. destruct (rs r1); simpl; auto. rewrite SF. + rewrite B. unfold getw. destruct (rs r1); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -+ unfold addimm32. - exploit (opimm32_correct Paddw Paddiw Val.add); eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. - rewrite B. simpl. destruct (rs r1); simpl; auto. rewrite SF. - rewrite Ptrofs.of_int_to_int by auto. auto. Qed. - +(* Lemma addptrofs_correct_2: forall rd r1 n k (rs: regset) m b ofs, r1 <> GPR31 -> rs#r1 = Vptr b of @@ -1202,8 +1196,11 @@ Proof. Opaque Int.eq. intros until c; intros TR EV. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -- (* move *) +- (* Omove *) destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrstack *) + exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. - (* Ocast32signed *) exploit cast32signed_correct; eauto. intros (rs' & A & B & C). exists rs'; split; eauto. split. apply B. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 977d3019..cb3b558c 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -340,16 +340,16 @@ module Target : TARGET = fprintf oc "%s end pseudoinstr btbl\n" comment *)| Pbuiltin(ef, args, res) -> begin match ef with - (*| EF_annot(kind,txt, targs) -> - begin match (P.to_int kind) with - | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in - fprintf oc "%s annotation: %S\n" comment annot - | 2 -> let lbl = new_label () in - fprintf oc "%a: " label lbl; - add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args - | _ -> assert false - end - *)| EF_debug(kind, txt, targs) -> + | EF_annot(kind,txt, targs) -> + begin match (P.to_int kind) with + | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot + (*| 2 -> let lbl = new_label () in + fprintf oc "%a: " label lbl; + add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args + *)| _ -> assert false + end + | EF_debug(kind, txt, targs) -> print_debug_info comment print_file_line preg_annot "sp" oc (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> -- cgit From eb3fd167668695c33f776cbb381c7664c3ec1858 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 17 Apr 2018 17:28:51 +0200 Subject: MPPA - Added Pmull -> now able to run the sort test --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/TargetPrinter.ml | 2 ++ 3 files changed, 7 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b2272f7a..f8ab1e8d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -226,6 +226,7 @@ Inductive instruction : Type := | Pandl (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) + | Pmull (rd: ireg) (rs1 rs2: ireg) (**r integer mulition long (low part) *) | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift left logical long *) | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift right logical long *) | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic long *) @@ -807,6 +808,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m | Pnegl d s => Next (nextinstr (rs#d <- (Val.negl rs###s))) m + | Pmull d s1 s2 => + Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m | Pslll d s1 s2 => Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m | Psrll d s1 s2 => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 9025a00d..d17ba14b 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -377,10 +377,10 @@ 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 :: k) - | Omull, a1 :: a2 :: nil => +*)| Omull, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmull rd rs1 rs2 :: k) - | Omullhs, a1 :: a2 :: nil => +(*| Omullhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhl rd rs1 rs2 :: k) | Omullhu, a1 :: a2 :: nil => diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index cb3b558c..4c3bf3c6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -216,6 +216,8 @@ module Target : TARGET = | Pmulw(rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pmull(rd, rs1, rs2) -> + fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psrliw (rd, rs, imm) -> fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm -- cgit From b7021853e651ddde91450cc83d3c77c5377efc06 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Apr 2018 14:27:44 +0200 Subject: MPPA - added Oaddrsymbol -> now able to run the matrix mult test --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 2 ++ mppa_k1c/Asmgenproof1.v | 26 +++++++++++++------------- 3 files changed, 17 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index d17ba14b..675cb065 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -262,12 +262,12 @@ Definition transl_op OK (if Float32.eq_dec f Float32.zero then Pfcvtsw rd GPR0 :: k else Ploadsi rd f :: k) - | Oaddrsymbol s ofs, nil => +*)| Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) then Ploadsymbol rd s Ptrofs.zero :: addptrofs rd rd ofs k else Ploadsymbol rd s ofs :: k) -*)| Oaddrstack n, nil => + | Oaddrstack n, nil => do rd <- ireg_of res; OK (addptrofs rd SP n k) diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 4150cba8..2003239e 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -317,6 +317,8 @@ Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. (* Omove *) - destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +(* Oaddrsymbol *) +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. (* Oaddimm32 *) - apply opimm32_label; intros; exact I. (* Oandimm32 *) diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 77643b8b..3085072e 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1198,6 +1198,19 @@ Opaque Int.eq. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. - (* Omove *) destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrsymbol *) + destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. ++ TranslOpSimpl. - (* Oaddrstack *) exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. @@ -1229,19 +1242,6 @@ Opaque Int.eq. + econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. -- (* addrsymbol *) - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). - exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. - intros (rs2 & A & B & C). - exists rs2; split. - apply exec_straight_step with rs1 m; auto. - split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). - rewrite Genv.shift_symbol_address. - replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). - exact B. - intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. -+ TranslOpSimpl. - (* stackoffset *) exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. -- cgit From aa25ec270b651186154523ec71a3888b50994d70 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Apr 2018 10:31:56 +0200 Subject: MPPA - Oshrximm + Mgetparam + FP is GPR10 + bug Added Oshrximm and Mgetparam -> mmult.c divide & conqueer generates FP is now GPR10 instead of being a mix of GPR30 and GPR32 Corrected a bug where Pgoto and Pj_l were given the same interpretation, where in fact there's a fundamental difference : Pgoto is supposed to have a function name (symbol), while Pj_l is supposed to have a label name (print_label). This led to having undefinite labels in the code. --- mppa_k1c/Asm.v | 5 +++-- mppa_k1c/Asmgen.v | 16 ++++++++-------- mppa_k1c/Asmgenproof.v | 32 +++++++++++++++++--------------- mppa_k1c/Asmgenproof1.v | 25 +++++++++++++------------ mppa_k1c/Machregs.v | 10 ++++++---- mppa_k1c/TargetPrinter.ml | 4 +++- 6 files changed, 50 insertions(+), 42 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f8ab1e8d..d199495b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -92,6 +92,7 @@ Module Pregmap := EMap(PregEq). (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'FP'" := GPR10 (only parsing) : asm. Notation "'RTMP'" := GPR31 (only parsing) : asm. Inductive btest: Type := @@ -1008,7 +1009,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out let sp := (Vptr stk Ptrofs.zero) in match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with | None => Stuck - | Some m2 => Next (nextinstr (rs #GPR32 <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 + | Some m2 => Next (nextinstr (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 end | Pfreeframe sz pos => match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with @@ -1082,7 +1083,7 @@ Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 -(*| R10 => GPR10 | R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 675cb065..8198fa78 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -346,7 +346,7 @@ Definition transl_op | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) -(*| Oshrximm n, a1 :: nil => + | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else Psraiw GPR31 rs (Int.repr 31) :: @@ -355,7 +355,7 @@ Definition transl_op Psraiw rd GPR31 n :: k) (* [Omakelong], [Ohighlong] should not occur *) -*)| Olowlong, a1 :: nil => + | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pcvtl2w rd rs :: k) | Ocast32signed, a1 :: nil => @@ -675,12 +675,12 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) loadind SP ofs ty dst k | Msetstack src ofs ty => storeind src SP ofs ty k -(*| Mgetparam ofs ty dst => + | Mgetparam ofs ty dst => (* load via the frame pointer if it is valid *) - do c <- loadind GPR30 ofs ty dst k; + do c <- loadind FP ofs ty dst k; OK (if ep then c - else loadind_ptr SP f.(fn_link_ofs) GPR30 c) -*)| Mop op args res => + else loadind_ptr SP f.(fn_link_ofs) FP c) + | Mop op args res => transl_op op args res k | Mload chunk addr args dst => transl_load chunk addr args dst k @@ -716,8 +716,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := match i with | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst R32) - | Mop op args res => before && negb (mreg_eq res R32) + | Mgetparam ofs ty dst => negb (mreg_eq dst R10) + | Mop op args res => before && negb (mreg_eq res R10) | _ => false end. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 2003239e..04335726 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -323,6 +323,8 @@ Opaque Int.eq. - apply opimm32_label; intros; exact I. (* Oandimm32 *) - apply opimm32_label; intros; exact I. +(* Oshrximm *) +- destruct (Int.eq n Int.zero); TailNoLabel. (* Oaddimm64 *) - apply opimm64_label; intros; exact I. (* Oandimm64 *) @@ -415,6 +417,9 @@ Proof. - eapply loadind_label; eauto. (* storeind *) - eapply storeind_label; eauto. +(* Mgetparam *) +- destruct ep. eapply loadind_label; eauto. + eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. (* transl_op *) - eapply transl_op_label; eauto. (* transl_load *) @@ -429,8 +434,7 @@ Proof. Qed. (* -- destruct ep. eapply loadind_label; eauto. - eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. + - eapply transl_op_label; eauto. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. - destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. @@ -552,7 +556,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (MEXT: Mem.extends m m') (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) - (DXP: ep = true -> rs#GPR32 = parent_sp s), + (DXP: ep = true -> rs#FP = parent_sp s), match_states (Mach.State s fb sp c ms m) (Asm.State rs m') | match_states_call: @@ -583,7 +587,7 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#GPR32 = parent_sp s)) -> + /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. @@ -694,9 +698,9 @@ Definition measure (s: Mach.state) : nat := | Mach.Returnstate _ _ _ => 1%nat end. -Remark preg_of_not_GPR32: forall r, negb (mreg_eq r R32) = true -> IR GPR32 <> preg_of r. +Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. Proof. - intros. change (IR GPR32) with (preg_of R32). red; intros. + intros. change (IR FP) with (preg_of R10). red; intros. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. @@ -748,16 +752,15 @@ Proof. intros [v' [C D]]. (* Opaque loadind. *) left; eapply exec_straight_steps; eauto; intros. monadInv TR. -(* destruct ep. -(* X30 contains parent *) +(* GPR31 contains parent *) exploit loadind_correct. eexact EQ. instantiate (2 := rs0). rewrite DXP; eauto. congruence. intros [rs1 [P [Q R]]]. exists rs1; split. eauto. split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_X30; auto. + apply preg_of_not_FP; auto. (* GPR11 does not contain parent *) rewrite chunk_of_Tptr in A. exploit loadind_ptr_correct. eexact A. congruence. intros [rs1 [P [Q R]]]. @@ -765,13 +768,12 @@ Proof. intros [rs2 [S [T U]]]. exists rs2; split. eapply exec_straight_trans; eauto. split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs1#X30 <- (rs2#X30)). intros. + instantiate (1 := rs1#FP <- (rs2#FP)). intros. rewrite Pregmap.gso; auto with asmgen. congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' X30). congruence. auto with asmgen. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_X30; auto. -*) + apply preg_of_not_FP; auto. - (* Mop *) assert (eval_operation tge sp op (map rs args) m = Some v). rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. @@ -783,7 +785,7 @@ Proof. apply agree_set_undef_mreg with rs0; auto. apply Val.lessdef_trans with v'; auto. simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_GPR32; auto. + rewrite R; auto. apply preg_of_not_FP; auto. Local Transparent destroyed_by_op. destruct op; simpl; auto; congruence. @@ -1021,7 +1023,7 @@ Local Transparent destroyed_by_op. Pget GPR8 RA :: storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#GPR32 <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). + set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. intros (rs' & U' & V'). exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 3085072e..21ff9738 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1214,6 +1214,18 @@ Opaque Int.eq. - (* Oaddrstack *) exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. +- (* Oshrximm *) + clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; unfold getw; Simpl. - (* Ocast32signed *) exploit cast32signed_correct; eauto. intros (rs' & A & B & C). exists rs'; split; eauto. split. apply B. @@ -1275,18 +1287,7 @@ Opaque Int.eq. exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* shrximm *) - clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. + - (* longofintu *) econstructor; split. eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ce86a06f..ed582c98 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -42,7 +42,7 @@ Require Import Op. Inductive mreg: Type := (* Allocatable General Purpose regs. *) | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R9 - (* R10 to R14 are reserved *) | R15 | R16 | R17 | R18 | R19 + | R10 (* R11 to R14 res *) | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 @@ -55,7 +55,7 @@ Global Opaque mreg_eq. Definition all_mregs := R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 - :: R15 :: R16 :: R17 :: R18 :: R19 + :: R10 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 @@ -87,6 +87,7 @@ Module IndexedMreg <: INDEXED_TYPE. match r with | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 + | R10 => 11 | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 @@ -115,6 +116,7 @@ Local Open Scope string_scope. Definition register_names := ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R9" , R9) + :: ("R10", R10) :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) @@ -173,9 +175,9 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := Definition destroyed_by_setstack (ty: typ): list mreg := nil. -Definition destroyed_at_function_entry: list mreg := R32 :: nil. +Definition destroyed_at_function_entry: list mreg := R10 :: nil. -Definition temp_for_parent_frame: mreg := R9. (* FIXME - and R8 ?? *) +Definition temp_for_parent_frame: mreg := R10. (* FIXME - and R8 ?? *) Definition destroyed_at_indirect_call: list mreg := nil. (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4c3bf3c6..b463a9c5 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -191,7 +191,9 @@ module Target : TARGET = let print_instruction oc = function | Pcall(s) -> fprintf oc " call %a\n;;\n" symbol s - | Pgoto(s) | Pj_l(s) -> + | Pgoto(s) -> + fprintf oc " goto %a\n;;\n" symbol s + | Pj_l(s) -> fprintf oc " goto %a\n;;\n" print_label s | Pret -> fprintf oc " ret\n;;\n" -- cgit From 7b3d2c0ab46292a47256ff484b812d3d3b2846c2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Apr 2018 11:38:31 +0200 Subject: MPPA - Added Ocast8signed and Ocast16signed --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof1.v | 28 ++++++++++++++-------------- 2 files changed, 16 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 8198fa78..0adc41b5 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -271,13 +271,13 @@ Definition transl_op do rd <- ireg_of res; OK (addptrofs rd SP n k) -(*| Ocast8signed, a1 :: nil => + | Ocast8signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) | Ocast16signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) -*)| Oadd, a1 :: a2 :: nil => + | Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddw rd rs1 rs2 :: k) | Oaddimm n, a1 :: nil => diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 21ff9738..44a02871 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1214,6 +1214,20 @@ Opaque Int.eq. - (* Oaddrstack *) exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. +- (* Ocast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. unfold getw. + 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. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. unfold getw. + 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 *) clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. destruct (Int.eq n Int.zero). @@ -1257,20 +1271,6 @@ Opaque Int.eq. - (* stackoffset *) exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. -- (* cast8signed *) - econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. -- (* cast16signed *) - econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* addimm *) exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). -- cgit From f73f3a4e5dda58408c82fe2657ddb251532ea894 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Apr 2018 14:38:06 +0200 Subject: MPPA - added remaining ops ; mult, div and floating point ops missing --- mppa_k1c/Asm.v | 21 +++++++++++++++++++++ mppa_k1c/Asmgen.v | 30 +++++++++++++++--------------- mppa_k1c/Asmgenproof.v | 6 ++++++ mppa_k1c/TargetPrinter.ml | 15 +++++++++++++++ 4 files changed, 57 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d199495b..c0caed5d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -193,6 +193,8 @@ Inductive instruction : Type := (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) + | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or immediate *) + | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor immediate *) | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate *) | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate *) @@ -202,6 +204,8 @@ Inductive instruction : Type := | Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subition *) | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer mulition *) | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) + | Porw (rd: ireg) (rs1 rs2: ireg) (**r or word *) + | Pxorw (rd: ireg) (rs1 rs2: ireg) (**r xor word *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift right logical *) @@ -211,6 +215,7 @@ Inductive instruction : Type := | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or long immediate *) + | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor long immediate *) | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate long *) | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate long *) | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) @@ -224,8 +229,10 @@ Inductive instruction : Type := (** 64-bit integer register-register instructions *) | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) + | Psubl (rd: ireg) (rs1 rs2: ireg) (**r integer long subition *) | Pandl (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) + | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r xor long *) | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) | Pmull (rd: ireg) (rs1 rs2: ireg) (**r integer mulition long (low part) *) | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift left logical long *) @@ -755,6 +762,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 32-bit integer register-immediate instructions *) | Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m + | Poriw d s i => + Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m + | Pxoriw d s i => + Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m | Pandiw d s i => Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m | Psraiw d s i => @@ -773,6 +784,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m | Pandw d s1 s2 => Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m + | Porw d s1 s2 => + Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m + | Pxorw d s1 s2 => + Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m | Pnegw d s => Next (nextinstr (rs#d <- (Val.neg rs###s))) m | Psrlw d s1 s2 => @@ -789,6 +804,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m | Poril d s i => Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m + | Pxoril d s i => + Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m | Psllil d s i => Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m | Psrlil d s i => @@ -803,10 +820,14 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m + | Psubl d s1 s2 => + Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m | Pandl d s1 s2 => Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m | Porl d s1 s2 => Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m + | Pxorl d s1 s2 => + Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m | Pnegl d s => Next (nextinstr (rs#d <- (Val.negl rs###s))) m | Pmull d s1 s2 => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 0adc41b5..744955de 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -83,9 +83,9 @@ Definition opimm32 (op: ireg -> ireg -> ireg -> instruction) Definition addimm32 := opimm32 Paddw Paddiw. Definition andimm32 := opimm32 Pandw Pandiw. -(* -Definition orimm32 := opimm32 Porw Poriw. +Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. +(* Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. @@ -109,9 +109,9 @@ end. Definition addimm64 := opimm64 Paddl Paddil. Definition orimm64 := opimm64 Porl Poril. Definition andimm64 := opimm64 Pandl Pandil. +Definition xorimm64 := opimm64 Pxorl Pxoril. (* -Definition xorimm64 := opimm64 Pxorl Pxoril. Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. *) @@ -310,13 +310,13 @@ Definition transl_op | Omodu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Premuw rd rs1 rs2 :: k) - | Oand, a1 :: a2 :: nil => +*)| Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 :: k) -*)| Oandimm n, a1 :: nil => + | Oandimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm32 rd rs n k) -(*| Oor, a1 :: a2 :: nil => + | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 :: k) | Oorimm n, a1 :: nil => @@ -328,7 +328,7 @@ Definition transl_op | Oxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm32 rd rs n k) -*)| Oshl, a1 :: a2 :: nil => + | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 :: k) | Oshlimm n, a1 :: nil => @@ -374,10 +374,10 @@ Definition transl_op | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegl rd rs :: k) -(*| Osubl, a1 :: a2 :: nil => + | Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubl rd rs1 rs2 :: k) -*)| Omull, a1 :: a2 :: nil => + | Omull, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmull rd rs1 rs2 :: k) (*| Omullhs, a1 :: a2 :: nil => @@ -398,25 +398,25 @@ Definition transl_op | Omodlu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Premul rd rs1 rs2 :: k) - | Oandl, a1 :: a2 :: nil => +*)| Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 :: k) -*)| Oandlimm n, a1 :: nil => + | Oandlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm64 rd rs n k) -(*| Oorl, a1 :: a2 :: nil => + | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 :: k) -*)| Oorlimm n, a1 :: nil => + | Oorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm64 rd rs n k) -(*| Oxorl, a1 :: a2 :: nil => + | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 :: k) | Oxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm64 rd rs n k) -*)| Oshll, a1 :: a2 :: nil => + | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 :: k) | Oshllimm n, a1 :: nil => diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 04335726..32241542 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -323,6 +323,10 @@ Opaque Int.eq. - apply opimm32_label; intros; exact I. (* Oandimm32 *) - apply opimm32_label; intros; exact I. +(* Oorimm32 *) +- apply opimm32_label; intros; exact I. +(* Oxorimm32 *) +- apply opimm32_label; intros; exact I. (* Oshrximm *) - destruct (Int.eq n Int.zero); TailNoLabel. (* Oaddimm64 *) @@ -331,6 +335,8 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. (* Oorimm64 *) - apply opimm64_label; intros; exact I. +(* Oxorimm64 *) +- apply opimm64_label; intros; exact I. Qed. (* diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index b463a9c5..01a4e269 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -214,6 +214,8 @@ module Target : TARGET = fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psubw(rd, rs1, rs2) -> + fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubl(rd, rs1, rs2) -> fprintf oc " sbfwd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pmulw(rd, rs1, rs2) -> @@ -250,6 +252,19 @@ module Target : TARGET = fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Porl(rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Poriw (rd, rs, imm) -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Porw(rd, rs1, rs2) -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Pxoriw (rd, rs, imm) -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxorw(rd, rs1, rs2) -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxorl(rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pandiw (rd, rs, imm) -> fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm -- cgit From bde53a2d485b6ba071fdf456251357cccd3bb6f5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Apr 2018 12:01:34 +0200 Subject: MPPA - Added ops for comparison operators --- mppa_k1c/Asm.v | 10 +- mppa_k1c/Asmgen.v | 79 ++++++++++++- mppa_k1c/Asmgenproof.v | 64 ++-------- mppa_k1c/Asmgenproof1.v | 291 ++++++++++++++-------------------------------- mppa_k1c/TargetPrinter.ml | 4 + 5 files changed, 186 insertions(+), 262 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index c0caed5d..c39cf74f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -187,8 +187,10 @@ Inductive instruction : Type := | Pmv (rd: ireg) (rs: ireg) (**r integer move *) (** Comparisons *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) - | Pcompd (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) + | Pcompiw (it: itest) (rd rs1: ireg) (imm: int) (**r integer comparison imm *) + | Pcompd (it: itest) (rd rs1 rs2: ireg) (**r integer comparison double *) + | Pcompid (it: itest) (rd rs1: ireg) (imm: int64) (**r integer comparison double imm *) (** 32-bit integer register-immediate instructions *) | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) @@ -756,8 +758,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Comparisons *) | Pcompw c d s1 s2 => Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m + | Pcompiw c d s i => + Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m | Pcompd c d s1 s2 => Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m + | Pcompid c d s i => + Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m (** 32-bit integer register-immediate instructions *) | Paddiw d s i => diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 744955de..e0af5f66 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -235,6 +235,81 @@ Definition transl_cbranch Error(msg "Asmgen.transl_cbranch") end. +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompw (itest_for_cmp cmp Signed) rd r1 r2 :: k. + +Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. + +Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompd (itest_for_cmp cmp Signed) rd r1 r2 :: k. + +Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompd (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. + +Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := + Pcompiw (itest_for_cmp cmp Signed) rd r1 n :: k. + +Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := + Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n :: k. + +Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := + Pcompid (itest_for_cmp cmp Signed) rd r1 n :: k. + +Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := + Pcompid (itest_for_cmp cmp Unsigned) rd r1 n :: k. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) +(*| Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) +*)| _, _ => + Error(msg "Asmgen.transl_cond_op") +end. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -537,10 +612,10 @@ Definition transl_op do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) - | Ocmp cmp, _ => +*)| Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k -*) + | _, _ => Error(msg "Asmgen.transl_op") end. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 32241542..39f832b4 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -251,64 +251,22 @@ Qed. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. *) -(* + Remark transl_cond_op_label: forall cond args r k c, transl_cond_op cond r args k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. -(* -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32s. - destruct (Int.eq n Int.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl. -* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. -* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. -* apply opimm32_label; intros; exact I. -* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. -* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. -* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. -- unfold transl_condimm_int32u. - destruct (Int.eq n Int.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl; - try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). - apply opimm32_label; intros; exact I. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64s. - destruct (Int64.eq n Int64.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl. -* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. -* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. -* apply opimm64_label; intros; exact I. -* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. -* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. -* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. -- unfold transl_condimm_int64u. - destruct (Int64.eq n Int64.zero). -+ destruct c0; simpl; TailNoLabel. -+ destruct c0; simpl; - try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). - apply opimm64_label; intros; exact I. -- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -*) +- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. Qed. -*) + Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. @@ -337,6 +295,8 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. (* Oxorimm64 *) - apply opimm64_label; intros; exact I. +(* Ocmp *) +- eapply transl_cond_op_label; eauto. Qed. (* diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 44a02871..2234404c 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -737,7 +737,7 @@ Proof. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. intros; Simpl. Qed. -(* + (** Translation of condition operators *) Lemma transl_cond_int32s_correct: @@ -747,24 +747,19 @@ Lemma transl_cond_int32s_correct: /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - intros. destruct cmp; simpl. + intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. + split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs##r1); auto. + split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. - simpl. rewrite (Val.negate_cmp_bool Clt). - destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). - destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_cond_int32u_correct: @@ -781,17 +776,12 @@ Proof. split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. - simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). - destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). - destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_cond_int64s_correct: @@ -803,22 +793,17 @@ Lemma transl_cond_int64s_correct: Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. + split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. + split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. - simpl. rewrite (Val.negate_cmpl_bool Clt). - destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). - destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_cond_int64u_correct: @@ -835,17 +820,12 @@ Proof. split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. split; intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. - simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). - destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. - econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). - destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_condimm_int32s_correct: @@ -856,60 +836,19 @@ Lemma transl_condimm_int32s_correct: /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros. unfold transl_condimm_int32s. - predSpec Int.eq Int.eq_spec n Int.zero. -- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). - exists rs'; eauto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm32 GPR31 n (transl_cond_int32s cmp rd r1 GPR31 k)) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). - { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ unfold xorimm32. - exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ unfold xorimm32. - exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). -* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. - unfold Int.lt. rewrite zlt_false. auto. - change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. - generalize (Int.signed_range i); omega. -* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. - unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). - destruct (zlt (Int.signed n) (Int.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. - rewrite Int.add_signed. symmetry; apply Int.signed_repr. - assert (Int.signed n <> Int.max_signed). - { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } - generalize (Int.signed_range n); omega. -+ apply DFL. -+ apply DFL. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_condimm_int32u_correct: @@ -920,30 +859,19 @@ Lemma transl_condimm_int32u_correct: /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros. unfold transl_condimm_int32u. - predSpec Int.eq Int.eq_spec n Int.zero. -- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. rewrite B; auto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm32 GPR31 n (transl_cond_int32u cmp rd r1 GPR31 k)) rs m k rs' m - /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). - { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ apply DFL. -+ apply DFL. -+ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. - intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ apply DFL. -+ apply DFL. -+ apply DFL. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_condimm_int64s_correct: @@ -954,60 +882,19 @@ Lemma transl_condimm_int64s_correct: /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros. unfold transl_condimm_int64s. - predSpec Int64.eq Int64.eq_spec n Int64.zero. -- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). - exists rs'; eauto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm64 GPR31 n (transl_cond_int64s cmp rd r1 GPR31 k)) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). - { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ unfold xorimm64. - exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ unfold xorimm64. - exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. - unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. - intros; transitivity (rs1 r); auto. -+ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). -* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. - unfold Int64.lt. rewrite zlt_false. auto. - change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. - generalize (Int64.signed_range i); omega. -* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. - rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. - unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). - destruct (zlt (Int64.signed n) (Int64.signed i)). - rewrite zlt_false by omega. auto. - rewrite zlt_true by omega. auto. - rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. - assert (Int64.signed n <> Int64.max_signed). - { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } - generalize (Int64.signed_range n); omega. -+ apply DFL. -+ apply DFL. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_condimm_int64u_correct: @@ -1018,30 +905,19 @@ Lemma transl_condimm_int64u_correct: /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros. unfold transl_condimm_int64u. - predSpec Int64.eq Int64.eq_spec n Int64.zero. -- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. rewrite B; auto. -- assert (DFL: - exists rs', - exec_straight ge fn (loadimm64 GPR31 n (transl_cond_int64u cmp rd r1 GPR31 k)) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r). - { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). - exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). - exists rs2; split. - eapply exec_straight_trans. eexact A1. eexact A2. - split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. - intros; transitivity (rs1 r); auto. } - destruct cmp. -+ apply DFL. -+ apply DFL. -+ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. - intros (rs1 & A1 & B1 & C1). - exists rs1; split. eexact A1. split; auto. rewrite B1; auto. -+ apply DFL. -+ apply DFL. -+ apply DFL. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. Qed. Lemma transl_cond_op_correct: @@ -1079,6 +955,9 @@ Proof. exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. +Qed. + +(* + (* cmpf *) destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. fold (Val.cmpf c0 (rs x) (rs x0)). @@ -1135,8 +1014,8 @@ Proof. * econstructor; split. apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. split; intros; Simpl. -Qed. *) + (** Some arithmetic properties. *) Remark cast32unsigned_from_cast32signed: @@ -1245,6 +1124,9 @@ Opaque Int.eq. exists rs'; split; eauto. split. apply B. intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } apply C; auto. +- (* Ocmp *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. (* - (* intconst *) exploit loadimm32_correct; eauto. intros (rs' & A & B & C). @@ -1325,9 +1207,6 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. -- (* cond *) - exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. *) Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 01a4e269..7930bbfa 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -287,8 +287,12 @@ module Target : TARGET = | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompiw (it, rd, rs1, imm) -> + fprintf oc " compiw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm | Pcompd (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompid (it, rd, rs1, imm) -> + fprintf oc " compid.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl -- cgit From 8441e61558f52e482e9ddc953b3a7c5c11977318 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Apr 2018 16:11:02 +0200 Subject: MPPA - Operands were inverted in SBFW and SBFD instructions --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 7930bbfa..6dd2bbad 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -214,9 +214,9 @@ module Target : TARGET = fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psubw(rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 | Psubl(rd, rs1, rs2) -> - fprintf oc " sbfwd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 | Pmulw(rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 -- cgit From aa26db13f4daedec371a17ee7f79ecce7f8fb60f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 25 Apr 2018 15:26:28 +0200 Subject: MPPA - Added coverage test --- mppa_k1c/TargetPrinter.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 6dd2bbad..b3c05f9c 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -196,7 +196,7 @@ module Target : TARGET = | Pj_l(s) -> fprintf oc " goto %a\n;;\n" print_label s | Pret -> - fprintf oc " ret\n;;\n" + fprintf oc " ret \n;;\n" | Pget (rd, rs) -> fprintf oc " get %a = %a\n;;\n" ireg rd preg rs | Pset (rd, rs) -> @@ -288,11 +288,11 @@ module Target : TARGET = | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompiw (it, rd, rs1, imm) -> - fprintf oc " compiw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm | Pcompd (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompid (it, rd, rs1, imm) -> - fprintf oc " compid.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl -- cgit From 819c6e0a77206f74c0b2b0ec656c47d8ef3068cf Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 26 Apr 2018 11:36:44 +0200 Subject: MPPA - fixed some typos in the TargetPrinter --- mppa_k1c/TargetPrinter.ml | 39 +++++---------------------------------- 1 file changed, 5 insertions(+), 34 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index b3c05f9c..57202ed6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -205,9 +205,9 @@ module Target : TARGET = fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs | Paddiw (rd, rs, imm) -> - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Paddw(rd, rs1, rs2) -> - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; @@ -267,9 +267,9 @@ module Target : TARGET = fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pandiw (rd, rs, imm) -> - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pandw(rd, rs1, rs2) -> - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; @@ -332,36 +332,7 @@ module Target : TARGET = fprintf oc "%a:\n" print_label lbl | Ploadsymbol(rd, id, ofs) -> loadsymbol oc rd id ofs - (*| Ploadsymbol_high(rd, id, ofs) -> - fprintf oc " lui %a, %%hi[%a]\n" ireg rd symbol_offset (id, ofs) - | Ploadli(rd, n) -> - let d = camlint64_of_coqint n in - let lbl = label_literal64 d in - fprintf oc " ld %a, %a %s %Lx\n" ireg rd label lbl comment d - | Ploadfi(rd, f) -> - let d = camlint64_of_coqint(Floats.Float.to_bits f) in - let lbl = label_literal64 d in - fprintf oc " fld %a, %a, x31 %s %.18g\n" - freg rd label lbl comment (camlfloat_of_coqfloat f) - | Ploadsi(rd, f) -> - let s = camlint_of_coqint(Floats.Float32.to_bits f) in - let lbl = label_literal32 s in - fprintf oc " flw %a, %a, x31 %s %.18g\n" - freg rd label lbl comment (camlfloat_of_coqfloat32 f) - | Pbtbl(r, tbl) -> - let lbl = new_label() in - fprintf oc "%s jumptable [ " comment; - List.iter (fun l -> fprintf oc "%a " print_label l) tbl; - fprintf oc "]\n"; - fprintf oc " sll x5, %a, 2\n" ireg r; - fprintf oc " la x31, %a\n" label lbl; - fprintf oc " add x5, x31, x5\n"; - fprintf oc " lw x5, 0(x5)\n"; - fprintf oc " add x5, x31, x5\n"; - fprintf oc " jr x5\n"; - jumptables := (lbl, tbl) :: !jumptables; - fprintf oc "%s end pseudoinstr btbl\n" comment - *)| Pbuiltin(ef, args, res) -> + | Pbuiltin(ef, args, res) -> begin match ef with | EF_annot(kind,txt, targs) -> begin match (P.to_int kind) with -- cgit From a2cc41ebb00e45792fc2d0ef3e25f77994cf826f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 26 Apr 2018 16:36:59 +0200 Subject: MPPA - FIX GPR10 is now the Frame Pointer in Asmexpand.ml (instead of GPR32) --- mppa_k1c/Asmexpand.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 51d63da5..301e1624 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -495,20 +495,20 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (GPR32, GPR12)); + emit (Pmv (GPR10, GPR12)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg full_sz)); - expand_storeind_ptr GPR32 GPR12 ofs; + expand_storeind_ptr GPR10 GPR12 ofs; let va_ofs = Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg sz)); - expand_storeind_ptr GPR32 GPR12 ofs; + expand_storeind_ptr GPR10 GPR12 ofs; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> -- cgit From a44f224bfa7c340188b54b3bd26a61e94567729b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 9 May 2018 14:04:31 +0200 Subject: Code cleaning --- mppa_k1c/Asm.v | 229 +++++++++++++++++++--------------------------- mppa_k1c/Asmgen.v | 19 +--- mppa_k1c/TargetPrinter.ml | 4 +- 3 files changed, 99 insertions(+), 153 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index c39cf74f..2df185a6 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -51,15 +51,6 @@ Inductive gpreg: Type := | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. Definition ireg := gpreg. - -(* -(* FIXME - placeholder definitions to make sure the Risc-V instruction definitions work *) -Inductive ireg0: Type := - | GPR: gpreg -> ireg0. - -Coercion GPR: gpreg >-> ireg0. -*) - Definition freg := gpreg. Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. @@ -139,115 +130,104 @@ Inductive offset : Type := | Ofsimm (ofs: ptrofs) | Ofslow (id: ident) (ofs: ptrofs). -(** The RISC-V instruction set is composed of several subsets. We model - the "32I" (32-bit integers), "64I" (64-bit integers), - "M" (multiplication and division), - "F" (single-precision floating-point) - and "D" (double-precision floating-point) subsets. - - For 32- and 64-bit integer arithmetic, the RISC-V instruction set comprises - generic integer operations such as ADD that operate over the full width - of an integer register (either 32 or 64 bit), plus specific instructions - such as ADDW that normalize their results to signed 32-bit integers. - Other instructions such as AND work equally well over 32- and 64-bit - integers, with the convention that 32-bit integers are represented - sign-extended in 64-bit registers. - - This clever design is challenging to formalize in the CompCert value - model. As a first step, we follow a more traditional approach, - also used in the x86 port, whereas we have two sets of (pseudo-) - instructions, one for 32-bit integer arithmetic, with suffix W, - the other for 64-bit integer arithmetic, with suffix L. The mapping - to actual instructions is done when printing assembly code, as follows: - - In 32-bit mode: - ADDW becomes ADD, ADDL is an error, ANDW becomes AND, ANDL is an error. - - In 64-bit mode: - ADDW becomes ADDW, ADDL becomes ADD, ANDW and ANDL both become AND. +(** We model a subset of the K1c instruction set. In particular, we do not + support floats yet. + + Although it is possible to use the 32-bits mode, for now we don't support it. + + We follow a design close to the one used for the Risc-V port: one set of + pseudo-instructions for 32-bit integer arithmetic, with suffix W, another + set for 64-bit integer arithmetic, with suffix L. + + When mapping to actual instructions, the OCaml code in TargetPrinter.ml + throws an error if we are not in 64-bits mode. *) Definition label := positive. (** A note on immediates: there are various constraints on immediate - operands to RISC-V instructions. We do not attempt to capture these + 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 RISC-V generator (file + representable range. Of course, our K1c generator (file [Asmgen]) is careful to respect this range. *) Inductive instruction : Type := -(** System Registers *) +(** Get/Set System Registers *) | Pget (rd: ireg) (rs: preg) (**r get system register *) | Pset (rd: preg) (rs: ireg) (**r set system register *) + (** Branch Control Unit instructions *) | Pret (**r return *) | Pcall (l: label) (**r function call *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) | Pgoto (l: label) (**r goto *) + | Pj_l (l: label) (**r jump to label *) + (* Conditional branches *) + | 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 *) -(** Register move *) - | Pmv (rd: ireg) (rs: ireg) (**r integer move *) +(** Integer Comparisons *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompiw (it: itest) (rd rs1: ireg) (imm: int) (**r comparison imm word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pcompil (it: itest) (rd rs1: ireg) (imm: int64) (**r comparison imm long *) -(** Comparisons *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r integer comparison *) - | Pcompiw (it: itest) (rd rs1: ireg) (imm: int) (**r integer comparison imm *) - | Pcompd (it: itest) (rd rs1 rs2: ireg) (**r integer comparison double *) - | Pcompid (it: itest) (rd rs1: ireg) (imm: int64) (**r integer comparison double imm *) +(** Load immediates *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + +(** Register move *) + | Pmv (rd: ireg) (rs: ireg) (**r register move *) (** 32-bit integer register-immediate instructions *) - | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add immediate *) - | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and immediate *) - | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or immediate *) - | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor immediate *) - | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate *) - | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate *) - | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate *) + | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add imm word *) + | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and imm word *) + | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or imm word *) + | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor imm word *) + | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical imm word *) (** 32-bit integer register-register instructions *) - | Paddw (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) - | Psubw (rd: ireg) (rs1 rs2: ireg) (**r integer subition *) - | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r integer mulition *) - | Pandw (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) + | Paddw (rd: ireg) (rs1 rs2: ireg) (**r add word *) + | Psubw (rd: ireg) (rs1 rs2: ireg) (**r sub word *) + | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r mul word *) + | Pandw (rd: ireg) (rs1 rs2: ireg) (**r and word *) | Porw (rd: ireg) (rs1 rs2: ireg) (**r or word *) | Pxorw (rd: ireg) (rs1 rs2: ireg) (**r xor word *) | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) - | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic *) - | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift right logical *) + | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift right logical word *) | Psllw (rd: ireg) (rs1 rs2: ireg) (**r shift left logical word *) (** 64-bit integer register-immediate instructions *) - | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate *) - | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate *) - | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or long immediate *) - | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor long immediate *) + | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or immediate long *) + | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor immediate long *) | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate long *) | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate long *) | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - -(** Conversions *) - | Pcvtl2w (rd: ireg) (rs: ireg) (**r Convert Long to Word *) - | Pcvtw2l (r : ireg) (**r Convert Word to Long *) - | Pmvw2l (rd: ireg) (rs: ireg) (**r Move Convert Word to Long *) (** 64-bit integer register-register instructions *) - | Paddl (rd: ireg) (rs1 rs2: ireg) (**r integer addition *) - | Psubl (rd: ireg) (rs1 rs2: ireg) (**r integer long subition *) - | Pandl (rd: ireg) (rs1 rs2: ireg) (**r integer andition *) + | Paddl (rd: ireg) (rs1 rs2: ireg) (**r add long *) + | Psubl (rd: ireg) (rs1 rs2: ireg) (**r sub long *) + | Pandl (rd: ireg) (rs1 rs2: ireg) (**r and long *) | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) - | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r xor long *) + | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r xor long *) | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) - | Pmull (rd: ireg) (rs1 rs2: ireg) (**r integer mulition long (low part) *) + | Pmull (rd: ireg) (rs1 rs2: ireg) (**r mul long (low part) *) | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift left logical long *) | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift right logical long *) | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic long *) - (* Unconditional jumps. Links are always to X1/RA. *) - | Pj_l (l: label) (**r jump to label *) - - (* Conditional branches *) - | 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 *) +(** Conversions *) + | Pcvtl2w (rd: ireg) (rs: ireg) (**r Convert Long to Word *) + | Pcvtw2l (r : ireg) (**r Convert Word to Long *) + | Pmvw2l (rd: ireg) (rs: ireg) (**r Move Convert Word to Long *) +(** Loads and Stores *) | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) @@ -735,6 +715,7 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := survive the execution of the pseudo-instruction. *) Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := +(** Get/Set system registers *) match i with | Pget rd ra => match ra with @@ -746,34 +727,58 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | RA => Next (nextinstr (rs#ra <- (rs#rd))) m | _ => Stuck end + +(** Branch Control Unit instructions *) | Pret => Next (rs#PC <- (rs#RA)) m | Pcall s => Next (rs#RA <- (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pgoto s => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pmv d s => - Next (nextinstr (rs#d <- (rs#s))) m + | Pj_l l => + goto_label f l rs m + | Pcb bt r l => + match cmp_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs##r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs###r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end (** Comparisons *) | Pcompw c d s1 s2 => Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m | Pcompiw c d s i => Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m - | Pcompd c d s1 s2 => + | Pcompl c d s1 s2 => Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m - | Pcompid c d s i => + | Pcompil c d s i => Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m +(** Load immediates *) + | Pmakel d i => + Next (nextinstr (rs#d <- (Vlong i))) m + | Pmake d i => + Next (nextinstr (rs#d <- (Vint i))) m + +(** Register move *) + | Pmv d s => + Next (nextinstr (rs#d <- (rs#s))) m + (** 32-bit integer register-immediate instructions *) | Paddiw d s i => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m + | Pandiw d s i => + Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m | Poriw d s i => Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m | Pxoriw d s i => Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m - | Pandiw d s i => - Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m | Psraiw d s i => Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m | Psrliw d s i => @@ -818,10 +823,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m | Psrail d s i => Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m - | Pmakel d i => - Next (nextinstr (rs#d <- (Vlong i))) m - | Pmake d i => - Next (nextinstr (rs#d <- (Vint i))) m (** 64-bit integer register-register instructions *) | Paddl d s1 s2 => @@ -853,54 +854,8 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmvw2l d s => Next (nextinstr (rs#d <- (Val.longofint rs#s))) m -(** Unconditional jumps. *) - | Pj_l l => - goto_label f l rs m - -(** Conditional branches *) - | Pcb bt r l => - match cmp_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - | Pcbu bt r l => - match cmpu_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs##r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs###r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end -(* -(** Conditional branches, 32-bit comparisons *) - | Pbeqw s1 s2 l => - eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Ceq rs##s1 rs##s2) - | Pbnew s1 s2 l => - eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Cne rs##s1 rs##s2) - | Pbltw s1 s2 l => - eval_branch f l rs m (Val.cmp_bool Clt rs##s1 rs##s2) - | Pbltuw s1 s2 l => - eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##s1 rs##s2) - | Pbgew s1 s2 l => - eval_branch f l rs m (Val.cmp_bool Cge rs##s1 rs##s2) - | Pbgeuw s1 s2 l => - eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) Cge rs##s1 rs##s2) - -(** Conditional branches, 64-bit comparisons *) - | Pbeql s1 s2 l => - eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Ceq rs###s1 rs###s2) - | Pbnel s1 s2 l => - eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Cne rs###s1 rs###s2) - | Pbltl s1 s2 l => - eval_branch f l rs m (Val.cmpl_bool Clt rs###s1 rs###s2) - | Pbltul s1 s2 l => - eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###s1 rs###s2) - | Pbgel s1 s2 l => - eval_branch f l rs m (Val.cmpl_bool Cge rs###s1 rs###s2) - | Pbgeul s1 s2 l => - eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) Cge rs###s1 rs###s2) - (** Loads and stores *) -*)| Plb d a ofs => + | Plb d a ofs => exec_load Mint8signed rs m d a ofs | Plbu d a ofs => exec_load Mint8unsigned rs m d a ofs @@ -1275,8 +1230,8 @@ Qed. Definition data_preg (r: preg) : bool := match r with | RA => false - | IR GPR31 => false (* FIXME - GPR31 is used as temporary in some instructions.. ??? *) - | IR GPR8 => false (* FIXME - idem *) + | IR GPR31 => false + | IR GPR8 => false | IR _ => true | FR _ => true | PC => false diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e0af5f66..05dc948e 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -64,11 +64,6 @@ Definition make_immed64 (val: int64) := Imm64_single val. are generated as required to perform the operation and prepended to the given instruction sequence [k]. *) -(* -Definition load_hilo32 (r: ireg) (hi lo: int) k := - if Int.eq lo Int.zero then Pluiw r hi :: k - else Pluiw r hi :: Paddiw r r lo :: k. -*) Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with | Imm32_single imm => Pmake r imm :: k @@ -88,10 +83,6 @@ Definition xorimm32 := opimm32 Pxorw Pxoriw. (* Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. - -Definition load_hilo64 (r: ireg) (hi lo: int64) k := - if Int64.eq lo Int64.zero then Pluil r hi :: k - else Pluil r hi :: Paddil r r lo :: k. *) Definition loadimm64 (r: ireg) (n: int64) (k: code) := @@ -136,7 +127,7 @@ Definition transl_comp Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompd (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. + Pcompl (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then @@ -246,10 +237,10 @@ Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompd (itest_for_cmp cmp Signed) rd r1 r2 :: k. + Pcompl (itest_for_cmp cmp Signed) rd r1 r2 :: k. Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompd (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. + Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := Pcompiw (itest_for_cmp cmp Signed) rd r1 n :: k. @@ -258,10 +249,10 @@ Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: co Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n :: k. Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompid (itest_for_cmp cmp Signed) rd r1 n :: k. + Pcompil (itest_for_cmp cmp Signed) rd r1 n :: k. Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompid (itest_for_cmp cmp Unsigned) rd r1 n :: k. + Pcompil (itest_for_cmp cmp Unsigned) rd r1 n :: k. Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: code) := diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 57202ed6..04dfe9e7 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -289,9 +289,9 @@ module Target : TARGET = fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompiw (it, rd, rs1, imm) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm - | Pcompd (it, rd, rs1, rs2) -> + | Pcompl (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcompid (it, rd, rs1, imm) -> + | Pcompil (it, rd, rs1, imm) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl -- cgit From b81dbb863781a5f450cad0b01f90f729fb1a2244 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 May 2018 17:13:14 +0200 Subject: MPPA - refactored instructions --- mppa_k1c/Asm.v | 561 ++++++++++++++++++++++++---------------------- mppa_k1c/Asmexpand.ml | 12 +- mppa_k1c/Asmgen.v | 154 ++++++------- mppa_k1c/Asmgenproof.v | 10 +- mppa_k1c/Asmgenproof1.v | 20 +- mppa_k1c/TargetPrinter.ml | 292 +++++++++++++----------- 6 files changed, 549 insertions(+), 500 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 2df185a6..008e6c67 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -152,12 +152,101 @@ Definition label := positive. representable range. Of course, our K1c generator (file [Asmgen]) is careful to respect this range. *) -Inductive instruction : Type := -(** Get/Set System Registers *) +(** Instructions to be expanded *) +Inductive ex_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 *) +(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) + | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) + | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) +. + +(** The pseudo-instructions are the following: + +- [Plabel]: define a code label at the current program point. + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Ploadli rd ival]: load an immediate 64-bit integer into an integer + register rd. Expands to a load from an address in the constant data section, + using the integer register x31 as temporary: +<< + lui x31, %hi(lbl) + ld rd, %lo(lbl)(x31) +lbl: + .quad ival +>> + +- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval + into a float register rd. + +- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval + into a float register rd. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. + +- [Pseq rd rs1 rs2]: since unsigned comparisons have particular + semantics for pointers, we cannot encode equality directly using + xor/sub etc, which have only integer semantics. +<< + xor rd, rs1, rs2 + sltiu rd, rd, 1 +>> + The [xor] is omitted if one of [rs1] and [rs2] is [x0]. + +- [Psne rd rs1 rs2]: similarly for unsigned inequality. +<< + xor rd, rs1, rs2 + sltu rd, x0, rd +>> +*) + +(** Control Flow instructions *) +Inductive cf_instruction : Type := | Pget (rd: ireg) (rs: preg) (**r get system register *) | Pset (rd: preg) (rs: ireg) (**r set system register *) - -(** Branch Control Unit instructions *) | Pret (**r return *) | Pcall (l: label) (**r function call *) (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) @@ -166,84 +255,123 @@ Inductive instruction : Type := (* Conditional branches *) | 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 *) +. -(** Integer Comparisons *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompiw (it: itest) (rd rs1: ireg) (imm: int) (**r comparison imm word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pcompil (it: itest) (rd rs1: ireg) (imm: int64) (**r comparison imm long *) - -(** Load immediates *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - -(** Register move *) - | Pmv (rd: ireg) (rs: ireg) (**r register move *) - -(** 32-bit integer register-immediate instructions *) - | Paddiw (rd: ireg) (rs: ireg) (imm: int) (**r add imm word *) - | Pandiw (rd: ireg) (rs: ireg) (imm: int) (**r and imm word *) - | Poriw (rd: ireg) (rs: ireg) (imm: int) (**r or imm word *) - | Pxoriw (rd: ireg) (rs: ireg) (imm: int) (**r xor imm word *) - | Psraiw (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrliw (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical imm word *) - -(** 32-bit integer register-register instructions *) - | Paddw (rd: ireg) (rs1 rs2: ireg) (**r add word *) - | Psubw (rd: ireg) (rs1 rs2: ireg) (**r sub word *) - | Pmulw (rd: ireg) (rs1 rs2: ireg) (**r mul word *) - | Pandw (rd: ireg) (rs1 rs2: ireg) (**r and word *) - | Porw (rd: ireg) (rs1 rs2: ireg) (**r or word *) - | Pxorw (rd: ireg) (rs1 rs2: ireg) (**r xor word *) - | Pnegw (rd: ireg) (rs: ireg) (**r negate word *) - | Psraw (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrlw (rd: ireg) (rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd: ireg) (rs1 rs2: ireg) (**r shift left logical word *) - -(** 64-bit integer register-immediate instructions *) - | Paddil (rd: ireg) (rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd: ireg) (rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd: ireg) (rs: ireg) (imm: int64) (**r or immediate long *) - | Pxoril (rd: ireg) (rs: ireg) (imm: int64) (**r xor immediate long *) - | Psllil (rd: ireg) (rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrlil (rd: ireg) (rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd: ireg) (rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - -(** 64-bit integer register-register instructions *) - | Paddl (rd: ireg) (rs1 rs2: ireg) (**r add long *) - | Psubl (rd: ireg) (rs1 rs2: ireg) (**r sub long *) - | Pandl (rd: ireg) (rs1 rs2: ireg) (**r and long *) - | Porl (rd: ireg) (rs1 rs2: ireg) (**r or long *) - | Pxorl (rd: ireg) (rs1 rs2: ireg) (**r xor long *) - | Pnegl (rd: ireg) (rs: ireg) (**r negate long *) - | Pmull (rd: ireg) (rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd: ireg) (rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd: ireg) (rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd: ireg) (rs1 rs2: ireg) (**r shift right arithmetic long *) - -(** Conversions *) - | Pcvtl2w (rd: ireg) (rs: ireg) (**r Convert Long to Word *) - | Pcvtw2l (r : ireg) (**r Convert Word to Long *) - | Pmvw2l (rd: ireg) (rs: ireg) (**r Move Convert Word to Long *) - -(** Loads and Stores *) +(** Loads **) +Inductive ld_instruction : Type := | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) + | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *) | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Psb (rd: ireg) (ra: ireg) (ofs: offset) (**r store byte *) - | Psh (rd: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) + | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) + | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) +. + +(** Stores **) +Inductive st_instruction : Type := + | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) + | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) +. + +(** Arithmetic instructions **) +Inductive arith_name_r : Type := + | Pcvtw2l (**r Convert Word to Long *) +. + +Inductive arith_name_rr : Type := + | Pmv (**r register move *) + | Pnegw (**r negate word *) + | Pnegl (**r negate long *) + | Pfnegd (**r float negate double *) + | Pcvtl2w (**r Convert Long to Word *) + | Pmvw2l (**r Move Convert Word to Long *) +. + +Inductive arith_name_ri32 : Type := + | Pmake (**r load immediate *) +. + +Inductive arith_name_ri64 : Type := + | Pmakel (**r load immediate long *) +. + +Inductive arith_name_rrr : Type := + | Pcompw (it: itest) (**r comparison word *) + | Pcompl (it: itest) (**r comparison long *) + + | Paddw (**r add word *) + | Psubw (**r sub word *) + | Pmulw (**r mul word *) + | Pandw (**r and word *) + | Porw (**r or word *) + | Pxorw (**r xor word *) + | Psraw (**r shift right arithmetic word *) + | Psrlw (**r shift right logical word *) + | Psllw (**r shift left logical word *) + + | Paddl (**r add long *) + | Psubl (**r sub long *) + | Pandl (**r and long *) + | Porl (**r or long *) + | Pxorl (**r xor long *) + | Pmull (**r mul long (low part) *) + | Pslll (**r shift left logical long *) + | Psrll (**r shift right logical long *) + | Psral (**r shift right arithmetic long *) +. + +Inductive arith_name_rri32 : Type := + | Pcompiw (it: itest) (**r comparison imm word *) + + | Paddiw (**r add imm word *) + | Pandiw (**r and imm word *) + | Poriw (**r or imm word *) + | Pxoriw (**r xor imm word *) + | Psraiw (**r shift right arithmetic imm word *) + | Psrliw (**r shift right logical imm word *) + | Pslliw (**r shift left logical imm word *) + + | Psllil (**r shift left logical immediate long *) + | Psrlil (**r shift right logical immediate long *) + | Psrail (**r shift right arithmetic immediate long *) +. + +Inductive arith_name_rri64 : Type := + | Pcompil (it: itest) (**r comparison imm long *) + | Paddil (**r add immediate long *) + | Pandil (**r and immediate long *) + | Poril (**r or immediate long *) + | Pxoril (**r xor immediate long *) +. + +Inductive ar_instruction : Type := + | PArithR (i: arith_name_r) (rd: ireg) + | PArithRR (i: arith_name_rr) (rd rs: ireg) + | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) + | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) + | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) + | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) +. + +Coercion PArithR: arith_name_r >-> Funclass. +Coercion PArithRR: arith_name_rr >-> Funclass. +Coercion PArithRI32: arith_name_ri32 >-> Funclass. +Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRRR: arith_name_rrr >-> Funclass. +Coercion PArithRRI32: arith_name_rri32 >-> Funclass. +Coercion PArithRRI64: arith_name_rri64 >-> Funclass. - (* Synchronization *) (*| Pfence (**r fence *) (* floating point register move *) @@ -251,9 +379,7 @@ Inductive instruction : Type := | Pfmvxs (rd: ireg) (rs: freg) (**r move FP single to integer register *) | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) - (* 32-bit (single-precision) floating point *) -*)| Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) - | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) +*)(* 32-bit (single-precision) floating point *) (*| Pfnegs (rd: freg) (rs: freg) (**r negation *) | Pfabss (rd: freg) (rs: freg) (**r absolute value *) @@ -286,14 +412,11 @@ Inductive instruction : Type := | Pfcvtsl (rd: freg) (rs: ireg) (**r int64 -> float32 conversion *) | Pfcvtslu (rd: freg) (rs: ireg) (**r unsigned int 64-> float32 conversion *) - (* 64-bit (double-precision) floating point *) -*)| Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) +*)(* 64-bit (double-precision) floating point *) (*| Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) -*)| Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) -(*| Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) + | Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) -*)| Pfnegd (rd: freg) (rs: freg) (**r negation *) -(*| Pfabsd (rd: freg) (rs: freg) (**r absolute value *) + | Pfabsd (rd: freg) (rs: freg) (**r absolute value *) | Pfaddd (rd: freg) (rs1 rs2: freg) (**r addition *) | Pfsubd (rd: freg) (rs1 rs2: freg) (**r subtraction *) @@ -326,93 +449,20 @@ Inductive instruction : Type := | Pfcvtds (rd: freg) (rs: freg) (**r float32 -> float *) | Pfcvtsd (rd: freg) (rs: freg) (**r float -> float32 *) *) - (* 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 *) -(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) - | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) - | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) - | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction. (**r built-in function (pseudo) *) - -(** The pseudo-instructions are the following: - -- [Plabel]: define a code label at the current program point. - -- [Ploadsymbol]: load the address of a symbol in an integer register. - Expands to the [la] assembler pseudo-instruction, which does the right - thing even if we are in PIC mode. - -- [Ploadli rd ival]: load an immediate 64-bit integer into an integer - register rd. Expands to a load from an address in the constant data section, - using the integer register x31 as temporary: -<< - lui x31, %hi(lbl) - ld rd, %lo(lbl)(x31) -lbl: - .quad ival ->> - -- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval - into a float register rd. - -- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval - into a float register rd. - -- [Pallocframe sz pos]: in the formal semantics, this - pseudo-instruction allocates a memory block with bounds [0] and - [sz], stores the value of the stack pointer at offset [pos] in this - block, and sets the stack pointer to the address of the bottom of - this block. - In the printed ASM assembly code, this allocation is: -<< - mv x30, sp - sub sp, sp, #sz - sw x30, #pos(sp) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. - -- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction - reads the word at [pos] of the block pointed by the stack pointer, - frees this block, and sets the stack pointer to the value read. - In the printed ASM assembly code, this freeing is just an increment of [sp]: -<< - add sp, sp, #sz ->> - Again, our memory model cannot comprehend that this operation - frees (logically) the current stack frame. - -- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table - as follows: -<< - la x31, table - add x31, x31, reg - jr x31 -table: .long table[0], table[1], ... ->> - Note that [reg] contains 4 times the index of the desired table entry. -- [Pseq rd rs1 rs2]: since unsigned comparisons have particular - semantics for pointers, we cannot encode equality directly using - xor/sub etc, which have only integer semantics. -<< - xor rd, rs1, rs2 - sltiu rd, rd, 1 ->> - The [xor] is omitted if one of [rs1] and [rs2] is [x0]. - -- [Psne rd rs1 rs2]: similarly for unsigned inequality. -<< - xor rd, rs1, rs2 - sltu rd, x0, rd ->> -*) +Inductive instruction : Type := + | PExpand (i: ex_instruction) + | PControlFlow (i: cf_instruction) + | PLoad (i: ld_instruction) + | PStore (i: st_instruction) + | PArith (i: ar_instruction) +. + +Coercion PExpand: ex_instruction >-> instruction. +Coercion PControlFlow: cf_instruction >-> instruction. +Coercion PLoad: ld_instruction >-> instruction. +Coercion PStore: st_instruction >-> instruction. +Coercion PArith: ar_instruction >-> instruction. Definition code := list instruction. Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. @@ -503,6 +553,7 @@ Lemma is_label_correct: if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. Proof. intros. destruct instr; simpl; try discriminate. + destruct i; simpl; try discriminate. case (peq lbl lbl0); intro; congruence. Qed. @@ -750,109 +801,81 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | (None, _) => Stuck end -(** Comparisons *) - | Pcompw c d s1 s2 => - Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m - | Pcompiw c d s i => - Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m - | Pcompl c d s1 s2 => - Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m - | Pcompil c d s i => - Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m - -(** Load immediates *) - | Pmakel d i => - Next (nextinstr (rs#d <- (Vlong i))) m - | Pmake d i => - Next (nextinstr (rs#d <- (Vint i))) m - -(** Register move *) - | Pmv d s => - Next (nextinstr (rs#d <- (rs#s))) m +(** Arithmetic Instructions *) + | PArithR n d => + match n with + | Pcvtw2l => Next (nextinstr (rs#d <- (Val.longofint rs#d))) m + end + + | PArithRR n d s => + match n with + | Pmv => Next (nextinstr (rs#d <- (rs#s))) m + | Pnegw => Next (nextinstr (rs#d <- (Val.neg rs###s))) m + | Pnegl => Next (nextinstr (rs#d <- (Val.negl rs###s))) m + | Pfnegd => Next (nextinstr (rs#d <- (Val.negf rs#s))) m + | Pcvtl2w => Next (nextinstr (rs#d <- (Val.loword rs###s))) m + | Pmvw2l => Next (nextinstr (rs#d <- (Val.longofint rs#s))) m + end + + | PArithRI32 n d i => + match n with + | Pmake => Next (nextinstr (rs#d <- (Vint i))) m + end + + | PArithRI64 n d i => + match n with + | Pmakel => Next (nextinstr (rs#d <- (Vlong i))) m + end -(** 32-bit integer register-immediate instructions *) - | Paddiw d s i => - Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m - | Pandiw d s i => - Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m - | Poriw d s i => - Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m - | Pxoriw d s i => - Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m - | Psraiw d s i => - Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m - | Psrliw d s i => - Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m - | Pslliw d s i => - Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m - -(** 32-bit integer register-register instructions *) - | Paddw d s1 s2 => - Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m - | Psubw d s1 s2 => - Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m - | Pmulw d s1 s2 => - Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m - | Pandw d s1 s2 => - Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m - | Porw d s1 s2 => - Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m - | Pxorw d s1 s2 => - Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m - | Pnegw d s => - Next (nextinstr (rs#d <- (Val.neg rs###s))) m - | Psrlw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m - | Psraw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m - | Psllw d s1 s2 => - Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m - -(** 64-bit integer register-immediate instructions *) - | Paddil d s i => - Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m - | Pandil d s i => - Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m - | Poril d s i => - Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m - | Pxoril d s i => - Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m - | Psllil d s i => - Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m - | Psrlil d s i => - Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m - | Psrail d s i => - Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m - -(** 64-bit integer register-register instructions *) - | Paddl d s1 s2 => - Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m - | Psubl d s1 s2 => - Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m - | Pandl d s1 s2 => - Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m - | Porl d s1 s2 => - Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m - | Pxorl d s1 s2 => - Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m - | Pnegl d s => - Next (nextinstr (rs#d <- (Val.negl rs###s))) m - | Pmull d s1 s2 => - Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m - | Pslll d s1 s2 => - Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m - | Psrll d s1 s2 => - Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m - | Psral d s1 s2 => - Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m - -(** Conversions *) - | Pcvtl2w d s => - Next (nextinstr (rs#d <- (Val.loword rs###s))) m - | Pcvtw2l r => - Next (nextinstr (rs#r <- (Val.longofint rs#r))) m - | Pmvw2l d s => - Next (nextinstr (rs#d <- (Val.longofint rs#s))) m + | PArithRRR n d s1 s2 => + match n with + | Pcompw c => Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m + | Pcompl c => Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m + | Paddw => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m + | Psubw => Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m + | Pmulw => Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m + | Pandw => Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m + | Porw => Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m + | Pxorw => Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m + | Psrlw => Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m + | Psraw => Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m + | Psllw => Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m + + | Paddl => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m + | Psubl => Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m + | Pandl => Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m + | Porl => Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m + | Pxorl => Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m + | Pmull => Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m + | Pslll => Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m + | Psrll => Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m + | Psral => Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m + end + + | PArithRRI32 n d s i => + match n with + | Pcompiw c => Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m + | Paddiw => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m + | Pandiw => Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m + | Poriw => Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m + | Pxoriw => Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m + | Psraiw => Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m + | Psrliw => Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m + | Pslliw => Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m + + | Psllil => Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m + | Psrlil => Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m + | Psrail => Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m + end + + | PArithRRI64 n d s i => + match n with + | Pcompil c => Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m + | Paddil => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m + | Pandil => Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m + | Poril => Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m + | Pxoril => Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m + end (** Loads and stores *) | Plb d a ofs => @@ -942,9 +965,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (*| Pfsd_a s a ofs => exec_store Many64 rs m s a ofs -*)| Pfnegd d s => - Next (nextinstr (rs#d <- (Val.negf rs#s))) m -(*| Pfabsd d s => + | Pfabsd d s => Next (nextinstr (rs#d <- (Val.absf rs#s))) m | Pfaddd d s1 s2 => @@ -1124,7 +1145,7 @@ Inductive step: state -> trace -> state -> Prop := forall b ofs f ef args res rs m vargs t vres rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (A:=instruction) (Pbuiltin ef args res) -> eval_builtin_args ge rs (rs SP) m args vargs -> external_call ef ge vargs m t vres m' -> rs' = nextinstr diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 301e1624..f0a9404c 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -493,9 +493,9 @@ let expand_builtin_inline name args res = let expand_instruction instr = match instr with - | Pallocframe (sz, ofs) -> + | PExpand Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (GPR10, GPR12)); + emit (PArith (PArithRR (Pmv, GPR10, GPR12))); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in @@ -511,7 +511,7 @@ let expand_instruction instr = expand_storeind_ptr GPR10 GPR12 ofs; vararg_start_ofs := None end - | Pfreeframe (sz, ofs) -> + | PExpand Pfreeframe (sz, ofs) -> let sg = get_current_function_sig() in let extra_sz = if sg.sig_cc.cc_vararg then begin @@ -548,10 +548,10 @@ let expand_instruction instr = end else begin emit (Pxorl(rd, rs1, rs2)); emit (Psltul(rd, X0, X rd)) end -*)| Pcvtl2w(rd, rs) -> +*)| PArith PArithRR (Pcvtl2w,rd, rs) -> assert Archi.ptr64; - emit (Paddiw(rd, rs, Int.zero)) (* 32-bit sign extension *) - | Pcvtw2l(r) -> + emit (PArith (PArithRRI32 (Paddiw,rd, rs, Int.zero))) (* 32-bit sign extension *) + | PArith PArithR r -> (* Pcvtw2l *) assert Archi.ptr64 (* no-operation because the 32-bit integer was kept sign extended already *) (* FIXME - is it really the case on the MPPA ? *) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 05dc948e..dbd7b4f5 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -58,6 +58,8 @@ Inductive immed64 : Type := (* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. +Notation "a ::i b" := (cons (A:=instruction) 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 @@ -66,14 +68,14 @@ Definition make_immed64 (val: int64) := Imm64_single val. Definition loadimm32 (r: ireg) (n: int) (k: code) := match make_immed32 n with - | Imm32_single imm => Pmake r imm :: k + | Imm32_single imm => Pmake r imm ::i k end. -Definition opimm32 (op: ireg -> ireg -> ireg -> instruction) - (opimm: ireg -> ireg -> int -> instruction) +Definition opimm32 (op: arith_name_rrr) + (opimm: arith_name_rri32) (rd rs: ireg) (n: int) (k: code) := match make_immed32 n with - | Imm32_single imm => opimm rd rs imm :: k + | Imm32_single imm => opimm rd rs imm ::i k end. Definition addimm32 := opimm32 Paddw Paddiw. @@ -87,14 +89,14 @@ Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition loadimm64 (r: ireg) (n: int64) (k: code) := match make_immed64 n with - | Imm64_single imm => Pmakel r imm :: k + | Imm64_single imm => Pmakel r imm ::i k end. -Definition opimm64 (op: ireg -> ireg -> ireg -> instruction) - (opimm: ireg -> ireg -> int64 -> instruction) +Definition opimm64 (op: arith_name_rrr) + (opimm: arith_name_rri64) (rd rs: ireg) (n: int64) (k: code) := match make_immed64 n with - | Imm64_single imm => opimm rd rs imm :: k + | Imm64_single imm => opimm rd rs imm ::i k end. Definition addimm64 := opimm64 Paddl Paddil. @@ -109,13 +111,13 @@ Definition sltuimm64 := opimm64 Psltul Psltiul. Definition cast32signed (rd rs: ireg) (k: code) := if (ireg_eq rd rs) - then Pcvtw2l rd :: k - else Pmvw2l rd rs :: k + then Pcvtw2l rd ::i k + else Pmvw2l rd rs ::i k . Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then - Pmv rd rs :: k + Pmv rd rs ::i k else addimm64 rd rs (Ptrofs.to_int64 n) k. @@ -123,11 +125,11 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := Definition transl_comp (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompw (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompl (itest_for_cmp c s) RTMP r1 r2 :: Pcb BTwnez RTMP lbl :: k. + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then @@ -143,8 +145,8 @@ Definition select_comp (n: int) (c: comparison) : option comparison := Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl :: k - | Some Cne => Pcbu BTwnez r1 lbl :: k + | Some Ceq => Pcbu BTweqz r1 lbl ::i k + | Some Cne => Pcbu BTwnez r1 lbl ::i k | Some _ => nil (* Never happens *) | None => loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k) end @@ -164,8 +166,8 @@ Definition select_compl (n: int64) (c: comparison) : option comparison := Definition transl_opt_compluimm (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_compl n c with - | Some Ceq => Pcbu BTdeqz r1 lbl :: k - | Some Cne => Pcbu BTdnez r1 lbl :: k + | Some Ceq => Pcbu BTdeqz r1 lbl ::i k + | Some Cne => Pcbu BTdnez r1 lbl ::i k | Some _ => nil (* Never happens *) | None => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k) end @@ -186,7 +188,7 @@ Definition transl_cbranch | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq n Int.zero then - Pcb (btest_for_cmpswz c) r1 lbl :: k + Pcb (btest_for_cmpswz c) r1 lbl ::i k else loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k) ) @@ -202,7 +204,7 @@ Definition transl_cbranch | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int64.eq n Int64.zero then - Pcb (btest_for_cmpsdz c) r1 lbl :: k + Pcb (btest_for_cmpsdz c) r1 lbl ::i k else loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k) ) @@ -231,28 +233,28 @@ Definition transl_cbranch condition. *) Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompw (itest_for_cmp cmp Signed) rd r1 r2 :: k. + Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. + Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompl (itest_for_cmp cmp Signed) rd r1 r2 :: k. + Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 :: k. + Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := - Pcompiw (itest_for_cmp cmp Signed) rd r1 n :: k. + Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := - Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n :: k. + Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompil (itest_for_cmp cmp Signed) rd r1 n :: k. + Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompil (itest_for_cmp cmp Unsigned) rd r1 n :: k. + Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: code) := @@ -309,7 +311,7 @@ Definition transl_op match op, args with | Omove, a1 :: nil => match preg_of res, preg_of a1 with - | IR r, IR a => OK (Pmv r a :: k) + | IR r, IR a => OK (Pmv r a ::i k) | _ , _ => Error(msg "Asmgen.Omove") end | Ointconst n, nil => @@ -331,33 +333,33 @@ Definition transl_op *)| Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) - then Ploadsymbol rd s Ptrofs.zero :: addptrofs rd rd ofs k - else Ploadsymbol rd s ofs :: k) + then Ploadsymbol rd s Ptrofs.zero ::i addptrofs rd rd ofs k + else Ploadsymbol rd s ofs ::i k) | Oaddrstack n, nil => do rd <- ireg_of res; OK (addptrofs rd SP n k) | Ocast8signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) + OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) | Ocast16signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) + OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k) | Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddw rd rs1 rs2 :: k) + OK (Paddw rd rs1 rs2 ::i k) | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm32 rd rs n k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pnegw rd rs :: k) + 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 :: k) + OK (Psubw rd rs1 rs2 ::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 :: k) + OK (Pmulw rd rs1 rs2 ::i k) (*| Omulhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhw rd rs1 rs2 :: k) @@ -378,52 +380,52 @@ Definition transl_op OK (Premuw rd rs1 rs2 :: k) *)| Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandw rd rs1 rs2 :: k) + OK (Pandw rd rs1 rs2 ::i k) | Oandimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm32 rd rs n k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porw rd rs1 rs2 :: k) + OK (Porw rd rs1 rs2 ::i k) | Oorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm32 rd rs n k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorw rd rs1 rs2 :: k) + OK (Pxorw rd rs1 rs2 ::i k) | Oxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm32 rd rs n k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psllw rd rs1 rs2 :: k) + OK (Psllw rd rs1 rs2 ::i k) | Oshlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs n :: k) + OK (Pslliw rd rs n ::i k) | Oshr, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psraw rd rs1 rs2 :: k) + OK (Psraw rd rs1 rs2 ::i k) | Oshrimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psraiw rd rs n :: k) + OK (Psraiw rd rs n ::i k) | Oshru, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrlw rd rs1 rs2 :: k) + OK (Psrlw rd rs1 rs2 ::i k) | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrliw rd rs n :: k) + OK (Psrliw rd rs n ::i k) | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psraiw GPR31 rs (Int.repr 31) :: - Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) :: - Paddw GPR31 rs GPR31 :: - Psraiw rd GPR31 n :: k) + OK (if Int.eq n Int.zero then Pmv rd rs ::i k else + Psraiw GPR31 rs (Int.repr 31) ::i + Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i + Paddw GPR31 rs GPR31 ::i + Psraiw rd GPR31 n ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pcvtl2w rd rs :: k) + OK (Pcvtl2w rd rs ::i k) | Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (cast32signed rd rs k) @@ -433,19 +435,19 @@ Definition transl_op OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) *)| Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddl rd rs1 rs2 :: k) + OK (Paddl rd rs1 rs2 ::i k) | Oaddlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm64 rd rs n k) | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pnegl rd rs :: k) + OK (Pnegl rd rs ::i k) | Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psubl rd rs1 rs2 :: k) + OK (Psubl rd rs1 rs2 ::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 :: k) + OK (Pmull rd rs1 rs2 ::i k) (*| Omullhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhl rd rs1 rs2 :: k) @@ -466,40 +468,40 @@ Definition transl_op OK (Premul rd rs1 rs2 :: k) *)| Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandl rd rs1 rs2 :: k) + OK (Pandl rd rs1 rs2 ::i k) | Oandlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm64 rd rs n k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porl rd rs1 rs2 :: k) + OK (Porl rd rs1 rs2 ::i k) | Oorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm64 rd rs n k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorl rd rs1 rs2 :: k) + OK (Pxorl rd rs1 rs2 ::i k) | Oxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm64 rd rs n k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pslll rd rs1 rs2 :: k) + OK (Pslll rd rs1 rs2 ::i k) | Oshllimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psllil rd rs n :: k) + OK (Psllil rd rs n ::i k) | Oshrl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psral rd rs1 rs2 :: k) + OK (Psral rd rs1 rs2 ::i k) | Oshrlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrail rd rs n :: k) + OK (Psrail rd rs n ::i k) | Oshrlu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrll rd rs1 rs2 :: k) + OK (Psrll rd rs1 rs2 ::i k) | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrlil rd rs n :: k) + OK (Psrlil rd rs n ::i k) (*| Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else @@ -510,7 +512,7 @@ Definition transl_op *)| Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegd rd rs :: k) + OK (Pfnegd rd rs ::i k) (*| Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs :: k) @@ -618,7 +620,7 @@ Definition indexed_memory_access (base: ireg) (ofs: ptrofs) (k: code) := match make_immed64 (Ptrofs.to_int64 ofs) with | Imm64_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) :: k + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) ::i k (*| Imm64_pair hi lo => Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k | Imm64_large imm => @@ -663,7 +665,7 @@ Definition transl_memory_access do rs <- ireg_of a1; OK (indexed_memory_access mk_instr rs ofs k) | Aglobal id ofs, nil => - OK (Ploadsymbol GPR31 id ofs :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k) + OK (Ploadsymbol GPR31 id ofs ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs k) | _, _ => @@ -730,7 +732,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) Definition make_epilogue (f: Mach.function) (k: code) := loadind_ptr SP f.(fn_retaddr_ofs) GPR8 - (Pset RA GPR8 :: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). + (Pset RA GPR8 ::i Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::i k). (** Translation of a Mach instruction. *) @@ -755,23 +757,23 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (*| Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) *)| Mcall sig (inr symb) => - OK ((Pcall symb) :: k) + OK ((Pcall symb) ::i k) (*| Mtailcall sig (inl r) => do r1 <- ireg_of r; OK (make_epilogue f (Pcall :: k)) *)| Mtailcall sig (inr symb) => - OK (make_epilogue f ((Pgoto symb) :: k)) + OK (make_epilogue f ((Pgoto symb) ::i k)) | Mbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::i k) | Mlabel lbl => - OK (Plabel lbl :: k) + OK (Plabel lbl ::i k) | Mgoto lbl => - OK (Pj_l lbl :: k) + OK (Pj_l lbl ::i k) | Mcond cond args lbl => transl_cbranch cond args lbl k (*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) *)| Mreturn => - OK (make_epilogue f (Pret :: k)) + OK (make_epilogue f (Pret ::i k)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | _ => Error (msg "Asmgen.transl_instr") @@ -821,8 +823,8 @@ Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bo Definition transl_function (f: Mach.function) := do c <- transl_code' f f.(Mach.fn_code) true; OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - Pget GPR8 RA :: + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i + Pget GPR8 RA ::i storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). Definition transf_function (f: Mach.function) : res Asm.function := diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 39f832b4..896e9ce9 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -124,7 +124,7 @@ Qed. Hint Resolve loadimm32_label: labels. Remark opimm32_label: - forall op opimm r1 r2 n k, + forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> tail_nolabel k (opimm32 op opimm r1 r2 n k). @@ -150,7 +150,7 @@ Qed. Hint Resolve cast32signed_label: labels. Remark opimm64_label: - forall op opimm r1 r2 n k, + forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> tail_nolabel k (opimm64 op opimm r1 r2 n k). @@ -376,7 +376,7 @@ Qed. Lemma transl_instr_label: forall f i ep k c, transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. + match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. Proof. unfold transl_instr; intros; destruct i; TailNoLabel. (* loadind *) @@ -985,8 +985,8 @@ Local Transparent destroyed_by_op. intros [m3' [P Q]]. (* Execution of function prologue *) monadInv EQ0. rewrite transl_code'_transl_code in EQ1. - set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) :: - Pget GPR8 RA :: + set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i + Pget GPR8 RA ::i storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index 2234404c..ecb06802 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -213,8 +213,8 @@ Qed. *) Lemma opimm64_correct: - forall (op: ireg -> ireg -> ireg -> instruction) - (opi: ireg -> ireg -> int64 -> instruction) + forall (op: arith_name_rrr) + (opi: arith_name_rri64) (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) -> @@ -328,7 +328,7 @@ Qed. Lemma transl_comp_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) @@ -356,7 +356,7 @@ Qed. Lemma transl_compu_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) @@ -383,7 +383,7 @@ Qed. Lemma transl_compl_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) @@ -412,7 +412,7 @@ Qed. Lemma transl_complu_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl :: k) rs' m + exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) @@ -1347,7 +1347,7 @@ Lemma Pget_correct: forall (dst: gpreg) (src: preg) k (rs: regset) m, src = RA -> exists rs', - exec_straight ge fn (Pget dst src :: k) rs m k rs' m + exec_straight ge fn (Pget dst src ::i k) rs m k rs' m /\ rs'#dst = rs#src /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. @@ -1362,7 +1362,7 @@ Lemma Pset_correct: forall (dst: preg) (src: gpreg) k (rs: regset) m, dst = RA -> exists rs', - exec_straight ge fn (Pset dst src :: k) rs m k rs' m + exec_straight ge fn (Pset dst src ::i k) rs m k rs' m /\ rs'#dst = rs#src /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. @@ -1546,7 +1546,7 @@ Proof. rewrite chunk_of_Tptr in *. exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 - :: Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs tm). + ::i Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs tm). - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - congruence. - intros (rs1 & A1 & B1 & C1). @@ -1555,7 +1555,7 @@ Proof. apply mkagree; auto. rewrite C1; discriminate || auto. intro. rewrite C1; auto; destruct r; simpl; try discriminate. - + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) :: k) rs1 tm). auto. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs1 tm). auto. intros (rs2 & A2 & B2 & C2). econstructor; econstructor; split. * eapply exec_straight_trans. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 04dfe9e7..8e3cce5a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -188,144 +188,12 @@ module Target : TARGET = let bcond oc c = fprintf oc "%s" (bcond_name c) (* Printing of instructions *) - let print_instruction oc = function - | Pcall(s) -> - fprintf oc " call %a\n;;\n" symbol s - | Pgoto(s) -> - fprintf oc " goto %a\n;;\n" symbol s - | Pj_l(s) -> - fprintf oc " goto %a\n;;\n" print_label s - | Pret -> - fprintf oc " ret \n;;\n" - | Pget (rd, rs) -> - fprintf oc " get %a = %a\n;;\n" ireg rd preg rs - | Pset (rd, rs) -> - fprintf oc " set %a = %a\n;;\n" preg rd ireg rs - | Pmv(rd, rs) | Pmvw2l(rd, rs) -> - fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs - - | Paddiw (rd, rs, imm) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Paddw(rd, rs1, rs2) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Paddil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Paddl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - | Psubw(rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 - | Psubl(rd, rs1, rs2) -> - fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 - - | Pmulw(rd, rs1, rs2) -> - fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pmull(rd, rs1, rs2) -> - fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psrlil (rd, rs, imm) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psrll (rd, rs1, rs2) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psrlw (rd, rs1, rs2) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psllw (rd, rs1, rs2) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psllil (rd, rs, imm) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pslll (rd, rs1, rs2) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psraw (rd, rs1, rs2) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psraiw (rd, rs1, imm) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 coqint64 imm - | Psral (rd, rs1, rs2) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psrail (rd, rs1, imm) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 coqint64 imm - - | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Porl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Porw(rd, rs1, rs2) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pxorw(rd, rs1, rs2) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pxorl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pandw(rd, rs1, rs2) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pandl(rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - | Pmake (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm - | Pmakel (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm - - | Pnegl(rd, rs) -> assert Archi.ptr64; - fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs - | Pnegw(rd, rs) -> - fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs - - | Pcompw (it, rd, rs1, rs2) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcompiw (it, rd, rs1, imm) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm - | Pcompl (it, rd, rs1, rs2) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcompil (it, rd, rs1, imm) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 coqint64 imm - | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl - - | Plb(rd, ra, ofs) -> - fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Plbu(rd, ra, ofs) -> - fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Plh(rd, ra, ofs) -> - fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Plhu(rd, ra, ofs) -> - fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - | Psb(rd, ra, ofs) -> - fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - | Psh(rd, ra, ofs) -> - fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - - | Pfnegd(rd, ra) -> - fprintf oc " fnegd %a = %a\n;;\n" ireg ra ireg rd - + let print_ex_instruction oc = function (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, ofs) -> assert false | Pfreeframe(sz, ofs) -> assert false - | Pcvtl2w _ | Pcvtw2l _ -> assert false (* Pseudo-instructions that remain *) | Plabel lbl -> @@ -354,6 +222,164 @@ module Target : TARGET = assert false end + let print_cf_instruction oc = function + | Pget (rd, rs) -> + fprintf oc " get %a = %a\n;;\n" ireg rd preg rs + | Pset (rd, rs) -> + fprintf oc " set %a = %a\n;;\n" preg rd ireg rs + | Pret -> + fprintf oc " ret \n;;\n" + | Pcall(s) -> + fprintf oc " call %a\n;;\n" symbol s + | Pgoto(s) -> + fprintf oc " goto %a\n;;\n" symbol s + | Pj_l(s) -> + fprintf oc " goto %a\n;;\n" print_label s + | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> + fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + + let print_ld_instruction oc = function + | Plb(rd, ra, ofs) -> + fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plbu(rd, ra, ofs) -> + fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plh(rd, ra, ofs) -> + fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plhu(rd, ra, ofs) -> + fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> + fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + + let print_st_instruction oc = function + | Psb(rd, ra, ofs) -> + fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psh(rd, ra, ofs) -> + fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> + fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + + let print_ar_r_instruction oc rd = (* function + | Pcvtw2l ->*) assert false + + let print_ar_rr_instruction oc rd rs = function + | Pmv | Pmvw2l -> + fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs + | Pcvtl2w -> assert false + | Pnegl -> assert Archi.ptr64; + fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs + | Pnegw -> + fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs + | Pfnegd -> + fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd + + let print_ar_ri32_instruction oc rd imm = (* function + | Pmake (rd, imm) -> *) + fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm + + let print_ar_ri64_instruction oc rd imm = (* function + | Pmakel (rd, imm) -> *) + fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm + + let print_ar_rrr_instruction oc rd rs1 rs2 = function + | Pcompw (it) -> + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompl (it) -> + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + + | Paddw -> + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubw -> + fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + | Pmulw -> + fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pandw -> + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Porw -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pxorw -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psraw -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrlw -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psllw -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Paddl -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubl -> + fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + | Pandl -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Porl -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pxorl -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pmull -> + fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pslll -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrll -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psral -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + let print_ar_rri32_instruction oc rd rs imm = function + | Pcompiw (it) -> + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + | Paddiw -> + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandiw -> + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Poriw -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxoriw -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psraiw -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrliw -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pslliw -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psllil -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrlil -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrail -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + + let print_ar_rri64_instruction oc rd rs imm = function + | Pcompil (it) -> + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + | Paddil -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandil -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Poril -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxoril -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + + let print_ar_instruction oc = function + | PArithR(d) -> print_ar_r_instruction oc d + | PArithRR(ins, d, s) -> print_ar_rr_instruction oc d s ins + | PArithRI32(d, i) -> print_ar_ri32_instruction oc d i + | PArithRI64(d, i) -> print_ar_ri64_instruction oc d i + | PArithRRR(ins, d, s1, s2) -> print_ar_rrr_instruction oc d s1 s2 ins + | PArithRRI32(ins, d, s, i) -> print_ar_rri32_instruction oc d s i ins + | PArithRRI64(ins, d, s, i) -> print_ar_rri64_instruction oc d s i ins + + let print_instruction oc = function + | PExpand(i) -> print_ex_instruction oc i + | PControlFlow(i) -> print_cf_instruction oc i + | PLoad(i) -> print_ld_instruction oc i + | PStore(i) -> print_st_instruction oc i + | PArith(i) -> print_ar_instruction oc i + let get_section_names name = let (text, lit) = match C2C.atom_sections name with -- cgit From 479aacd0254605942a3f48c3b8053af4d07f0f6c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 May 2018 16:34:36 +0200 Subject: MPPA - Added modulo and division 64 bits. Non certified 32 bits version are not yet there. Right now the code is directly from libgcc, compiled with k1-gcc because of builtins. --- mppa_k1c/Asmgen.v | 6 +++--- mppa_k1c/Asmgenproof1.v | 17 ++++++++++------- mppa_k1c/Machregs.v | 8 ++++---- mppa_k1c/SelectLong.v | 12 ++++-------- mppa_k1c/SelectLongproof.v | 12 ++++-------- 5 files changed, 25 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index dbd7b4f5..6b6531c3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -429,11 +429,11 @@ Definition transl_op | Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (cast32signed rd rs k) -(*| Ocast32unsigned, a1 :: nil => + | Ocast32unsigned, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); - OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) -*)| Oaddl, a1 :: a2 :: nil => + OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) + | Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 ::i k) | Oaddlimm n, a1 :: nil => diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v index ecb06802..bb39b4a5 100644 --- a/mppa_k1c/Asmgenproof1.v +++ b/mppa_k1c/Asmgenproof1.v @@ -1124,6 +1124,15 @@ Opaque Int.eq. exists rs'; split; eauto. split. apply B. intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } apply C; auto. +- (* longofintu *) + econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. + split; intros; Simpl. unfold getl; unfold Pregmap.set; Simpl. destruct (PregEq.eq x0 x0). + + destruct (rs x0); auto. simpl. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. + rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. + + contradict n. auto. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. @@ -1170,13 +1179,7 @@ Opaque Int.eq. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* longofintu *) - econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. - split; intros; Simpl. destruct (rs x0); auto. simpl. - assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. - rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. + - (* addlimm *) exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ed582c98..bed3c040 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -208,11 +208,11 @@ Global Opaque integers as their 64-bit sign extension; and [Ocast32unsigned], because it builds on the same magic no-op. *) -Definition two_address_op (op: operation) : bool := false. - (* match op with - | Ocast32signed | Ocast32unsigned => true +Definition two_address_op (op: operation) : bool := + match op with + | Ocast32unsigned => true | _ => false - end. *) + end. (** Constraints on constant propagation for builtins *) diff --git a/mppa_k1c/SelectLong.v b/mppa_k1c/SelectLong.v index 876d02fb..f2aa6be2 100644 --- a/mppa_k1c/SelectLong.v +++ b/mppa_k1c/SelectLong.v @@ -706,14 +706,10 @@ Definition notl (e: expr) := (** ** Integer division and modulus *) -Definition divlu_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil). -Definition modlu_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil). -Definition divls_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil). -Definition modls_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). +Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. +Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. +Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. +Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. Definition shrxlimm (e: expr) (n: int) := if Archi.splitlong then SplitLong.shrxlimm e n else diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 511dee92..d12fb9ae 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -447,30 +447,26 @@ Qed. Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. Proof. - unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL. + unfold divls_base; red; intros. eapply SplitLongproof.eval_divls_base; eauto. - TrivialExists. Qed. Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. Proof. - unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL. + unfold modls_base; red; intros. eapply SplitLongproof.eval_modls_base; eauto. - TrivialExists. Qed. Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. Proof. - unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL. + unfold divlu_base; red; intros. eapply SplitLongproof.eval_divlu_base; eauto. - TrivialExists. Qed. Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. Proof. - unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL. + unfold modlu_base; red; intros. eapply SplitLongproof.eval_modlu_base; eauto. - TrivialExists. Qed. Theorem eval_shrxlimm: -- cgit From 616f796999a47aa12aa60b0dc39274dd4fe7a2ca Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 30 May 2018 17:41:25 +0200 Subject: WIP - Trying to add builtins support. They are not detected for now :( --- mppa_k1c/Asm.v | 27 ++++++--------------------- mppa_k1c/Asmexpand.ml | 8 ++++---- mppa_k1c/CBuiltins.ml | 31 ++++++++++++++++++------------- mppa_k1c/TargetPrinter.ml | 6 ++++++ 4 files changed, 34 insertions(+), 38 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 008e6c67..df394ecf 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -166,6 +166,9 @@ Inductive ex_instruction : Type := | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) + (* Instructions not generated by Asmgen (most likely result of AsmExpand) *) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) . (** The pseudo-instructions are the following: @@ -1053,28 +1056,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) -(*| Pfence - - | Pfmvxs _ _ - | Pfmvxd _ _ - - | Pfmins _ _ _ - | Pfmaxs _ _ _ - | Pfsqrts _ _ - | Pfmadds _ _ _ _ - | Pfmsubs _ _ _ _ - | Pfnmadds _ _ _ _ - | Pfnmsubs _ _ _ _ - - | Pfmind _ _ _ - | Pfmaxd _ _ _ - | Pfsqrtd _ _ - | Pfmaddd _ _ _ _ - | Pfmsubd _ _ _ _ - | Pfnmaddd _ _ _ _ - | Pfnmsubd _ _ _ _ + | Pclzll _ _ + | Pstsud _ _ _ => Stuck -*)end. + end. (** Translation of the LTL/Linear/Mach view of machine registers to the RISC-V view. Note that no LTL register maps to [X31]. This diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index f0a9404c..282fa476 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -565,11 +565,11 @@ let expand_instruction instr = | Pj_s(symb, sg) -> fixup_call sg; emit instr - | Pbuiltin (ef,args,res) -> +*)| PExpand Pbuiltin (ef,args,res) -> begin match ef with | EF_builtin (name,sg) -> expand_builtin_inline (camlstring_of_coqstring name) args res - | EF_vload chunk -> + (*| EF_vload chunk -> expand_builtin_vload chunk args res | EF_vstore chunk -> expand_builtin_vstore chunk args @@ -579,10 +579,10 @@ let expand_instruction instr = expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr - | _ -> + *)| _ -> assert false end -*)| _ -> + | _ -> emit instr (* NOTE: Dwarf register maps for RV32G are not yet specified diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 0c981d11..b478f9b3 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -22,34 +22,39 @@ let builtins = { "__builtin_va_list", TPtr(TVoid [], []) ]; Builtins.functions = [ + "__builtin_clzll", + (TInt(IInt, []), + [TInt(IULongLong, [])], false); + "__builtin_k1_stsud", + (TInt(IULongLong, []), + [TInt(IULongLong, []); TInt(IULongLong, [])], false); (* Synchronization *) - "__builtin_fence", +(* "__builtin_fence", (TVoid [], [], false); (* Integer arithmetic *) "__builtin_bswap64", - (TInt(IULongLong, []), [TInt(IULongLong, [])], false); + (TInt(IULongLong, []), + [TInt(IULongLong, [])], false); (* Float arithmetic *) "__builtin_fmadd", (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fmsub", (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fnmadd", (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); + [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_fmax", - (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fmin", - (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); - ] + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); +*)] } let va_list_type = TPtr(TVoid [], []) (* to check! *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8e3cce5a..ad06500e 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -222,6 +222,12 @@ module Target : TARGET = assert false end + (* Pseudo-instructions not generated by Asmgen *) + | Pclzll(rd, rs) -> + fprintf oc " clzll %a = %a\n;;\n" ireg rd ireg rs + | Pstsud(rd, rs1, rs2) -> + fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + let print_cf_instruction oc = function | Pget (rd, rs) -> fprintf oc " get %a = %a\n;;\n" ireg rd preg rs -- cgit From 48762e6309dc92ac7788a30c0ca1007715fce4db Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Jun 2018 13:54:40 +0200 Subject: MPPA - Added Builtins support. Starting with clzll and stsud --- mppa_k1c/Asmexpand.ml | 65 ++++------------------------------------------- mppa_k1c/TargetPrinter.ml | 2 +- 2 files changed, 6 insertions(+), 61 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 282fa476..b3a1e836 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -417,73 +417,18 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () -(*| "__builtin_fence", [], _ -> - emit Pfence -*)(* Vararg stuff *) + (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a + | "__builtin_clzll", [BA(IR a)], BR(IR res) -> + emit (PExpand (Pclzll(res, a))) + | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> + emit (PExpand (Pstsud(res, a1, a2))) (* Byte swaps *) (*| "__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 a1)], BR(IR res) -> - expand_bswap64 res a1 - | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = X6 && al = X5 && rh = X5 && rl = X6); - expand_bswap32 X5 X5; - expand_bswap32 X6 X6 - (* Float arithmetic *) | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> emit (Pfabsd(res, a1)) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> - emit (Pfsqrtd(res, a1)) - | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> - emit (Pfmaddd(res, a1, a2, a3)) - | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> - emit (Pfmsubd(res, a1, a2, a3)) - | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> - emit (Pfnmaddd(res, a1, a2, a3)) - | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> - emit (Pfnmsubd(res, a1, a2, a3)) - | "__builtin_fmin", [BA(FR a1); BA(FR a2)], BR(FR res) -> - emit (Pfmind(res, a1, a2)) - | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) -> - emit (Pfmaxd(res, a1, a2)) - (* 64-bit integer arithmetic for a 32-bit platform *) - | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - expand_int64_arith (rl = ah) rl - (fun rl -> - emit (Psltuw (X1, X0, X al)); - emit (Psubw (rl, X0, X al)); - emit (Psubw (rh, X0, X ah)); - emit (Psubw (rh, X rh, X X1))) - | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); - BA_splitlong(BA(IR bh), BA(IR bl))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - expand_int64_arith (rl = bl || rl = ah || rl = bh) rl - (fun rl -> - emit (Paddw (rl, X al, X bl)); - emit (Psltuw (X1, X rl, X bl)); - emit (Paddw (rh, X ah, X bh)); - emit (Paddw (rh, X rh, X X1))) - | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); - BA_splitlong(BA(IR bh), BA(IR bl))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - expand_int64_arith (rl = ah || rl = bh) rl - (fun rl -> - emit (Psltuw (X1, X al, X bl)); - emit (Psubw (rl, X al, X bl)); - emit (Psubw (rh, X ah, X bh)); - emit (Psubw (rh, X rh, X X1))) - | "__builtin_mull", [BA(IR a); BA(IR b)], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - expand_int64_arith (rl = a || rl = b) rl - (fun rl -> - emit (Pmulw (rl, X a, X b)); - emit (Pmulhuw (rh, X a, X b))) *) (* Catch-all *) | _ -> diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ad06500e..41ea06e4 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -224,7 +224,7 @@ module Target : TARGET = (* Pseudo-instructions not generated by Asmgen *) | Pclzll(rd, rs) -> - fprintf oc " clzll %a = %a\n;;\n" ireg rd ireg rs + fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs | Pstsud(rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 -- cgit From 080875012a740b9fbe9ad9e1d147543ce538a955 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Aug 2018 17:23:31 +0200 Subject: Added all the working builtins for ALU. Added BCU and LSU without testing --- mppa_k1c/Asm.v | 123 +++++++++++++++++++++++++++++++++++++++++++++- mppa_k1c/Asmexpand.ml | 72 +++++++++++++++++++++++++-- mppa_k1c/CBuiltins.ml | 76 +++++++++++++++++++++++++--- mppa_k1c/TargetPrinter.ml | 115 ++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 372 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index df394ecf..9de80a15 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -167,7 +167,66 @@ Inductive ex_instruction : Type := | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) (* Instructions not generated by Asmgen (most likely result of AsmExpand) *) - | Pclzll (rd rs: ireg) + (* BCU *) + | Pawait + | Pbarrier + | Pdoze + | Pwfxl (rs1 rs2: ireg) + | Pwfxm (rs1 rs2: ireg) + | Pinvaldtlb + | Pinvalitlb + | Pprobetlb + | Preadtlb + | Psleep + | Pstop + | Psyncgroup (rs: ireg) + | Ptlbwrite + + (* LSU *) + | Pafda (rd rs1 rs2: ireg) + | Paldc (rd rs: ireg) + | Pdinval + | Pdinvall (rs: ireg) + | Pdtouchl (rs: ireg) + | Pdzerol (rs: ireg) + | Pfence + | Piinval + | Piinvals (rs: ireg) + | Pitouchl (rs: ireg) + | Plbsu (rd rs: ireg) + | Plbzu (rd rs: ireg) + | Pldu (rd rs: ireg) + | Plhsu (rd rs: ireg) + | Plhzu (rd rs: ireg) + | Plwzu (rd rs: ireg) + + (* ALU *) + | Paddhp (rd rs1 rs2: ireg) + | Padds (rd rs1 rs2: ireg) + | Pbwlu (rd rs1 rs2 rs3 rs4 rs5: ireg) + | Pbwluhp (rd rs1 rs2 rs3: ireg) + | Pbwluwp (rd rs1 rs2 rs3: ireg) + | Pcbs (rd rs: ireg) + | Pcbsdl (rd rs: ireg) + | Pclz (rd rs: ireg) + | Pclzw (rd rs: ireg) + | Pclzd (rd rs: ireg) + | Pclzdl (rd rs: ireg) + | Pcmove (rd rs1 rs2 rs3: ireg) + | Pctz (rd rs: ireg) + | Pctzw (rd rs: ireg) + | Pctzd (rd rs: ireg) + | Pctzdl (rd rs: ireg) + | Pextfz (rd rs1 rs2 rs3: ireg) + | Plandhp (rd rs1 rs2 rs3: ireg) + | Psat (rd rs1 rs2: ireg) + | Psatd (rd rs1 rs2: ireg) + | Psbfhp (rd rs1 rs2: ireg) + | Psbmm8 (rd rs1 rs2: ireg) + | Psbmmt8 (rd rs1 rs2: ireg) + | Psllhps (rd rs1 rs2: ireg) + | Psrahps (rd rs1 rs2: ireg) + | Pstsu (rd rs1 rs2: ireg) | Pstsud (rd rs1 rs2: ireg) . @@ -1056,8 +1115,68 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) - | Pclzll _ _ + (* BCU *) + | Pawait + | Pbarrier + | Pdoze + | Pwfxl _ _ + | Pwfxm _ _ + | Pinvaldtlb + | Pinvalitlb + | Pprobetlb + | Preadtlb + | Psleep + | Pstop + | Psyncgroup _ + | Ptlbwrite + + (* LSU *) + | Pafda _ _ _ + | Paldc _ _ + | Pdinval + | Pdinvall _ + | Pdtouchl _ + | Pdzerol _ + | Pfence + | Piinval + | Piinvals _ + | Pitouchl _ + | Plbsu _ _ + | Plbzu _ _ + | Pldu _ _ + | Plhsu _ _ + | Plhzu _ _ + | Plwzu _ _ + + (* ALU *) + | Paddhp _ _ _ + | Padds _ _ _ + | Pbwlu _ _ _ _ _ _ + | Pbwluhp _ _ _ _ + | Pbwluwp _ _ _ _ + | Pcbs _ _ + | Pcbsdl _ _ + | Pclz _ _ + | Pclzw _ _ + | Pclzd _ _ + | Pclzdl _ _ + | Pcmove _ _ _ _ + | Pctz _ _ + | Pctzw _ _ + | Pctzd _ _ + | Pctzdl _ _ + | Pextfz _ _ _ _ + | Plandhp _ _ _ _ + | Psat _ _ _ + | Psatd _ _ _ + | Psbfhp _ _ _ + | Psbmm8 _ _ _ + | Psbmmt8 _ _ _ + | Psllhps _ _ _ + | Psrahps _ _ _ + | Pstsu _ _ _ | Pstsud _ _ _ + => Stuck end. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index b3a1e836..951a7511 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -417,13 +417,77 @@ let expand_builtin_inline name args res = (* Synchronization *) | "__builtin_membar", [], _ -> () + (* BCU *) + | "__builtin_k1_await", [], BR(IR _) -> emit (PExpand (Pawait)) + | "__builtin_k1_barrier", [], BR(IR _) -> emit (PExpand (Pbarrier)) + | "__builtin_k1_doze", [], BR(IR _) -> emit (PExpand (Pdoze)) + | "__builtin_k1_wfxl", [BA(IR a1); BA(IR a2)], BR(IR _) -> emit (PExpand (Pwfxl(a1, a2))) + | "__builtin_k1_wfxm", [BA(IR a1); BA(IR a2)], BR(IR _) -> emit (PExpand (Pwfxm(a1, a2))) + | "__builtin_k1_invaldtlb", [], BR(IR _) -> emit (PExpand (Pinvaldtlb)) + | "__builtin_k1_invalitlb", [], BR(IR _) -> emit (PExpand (Pinvalitlb)) + | "__builtin_k1_probetlb", [], BR(IR _) -> emit (PExpand (Pprobetlb)) + | "__builtin_k1_readtlb", [], BR(IR _) -> emit (PExpand (Preadtlb)) + | "__builtin_k1_sleep", [], BR(IR _) -> emit (PExpand (Psleep)) + | "__builtin_k1_stop", [], BR(IR _) -> emit (PExpand (Pstop)) + | "__builtin_k1_syncgroup", [BA(IR a1)], BR(IR _) -> emit (PExpand (Psyncgroup(a1))) + | "__builtin_k1_tlbwrite", [], BR(IR _) -> emit (PExpand (Ptlbwrite)) + + (* LSU *) + | "__builtin_k1_afda", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pafda(r, a1, a2))) + | "__builtin_k1_aldc", [BA(IR a1)], BR(IR r) -> emit (PExpand (Paldc(r, a1))) + | "__builtin_k1_dinval", [], BR(IR _) -> emit (PExpand (Pdinval)) + | "__builtin_k1_dinvall", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdinvall(a1))) + | "__builtin_k1_dtouchl", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdtouchl(a1))) + | "__builtin_k1_dzerol", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdzerol(a1))) + | "__builtin_k1_fence", [], BR(IR _) -> emit (PExpand (Pfence)) + | "__builtin_k1_iinval", [], BR(IR _) -> emit (PExpand (Piinval)) + | "__builtin_k1_iinvals", [BA(IR a1)], BR(IR _) -> emit (PExpand (Piinvals(a1))) + | "__builtin_k1_itouchl", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pitouchl(a1))) + | "__builtin_k1_lbsu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plbsu(r, a1))) + | "__builtin_k1_lbzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plbzu(r, a1))) + | "__builtin_k1_ldu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pldu(r, a1))) + | "__builtin_k1_lhsu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plhsu(r, a1))) + | "__builtin_k1_lhzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plhzu(r, a1))) + | "__builtin_k1_lwzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plwzu(r, a1))) + + (* ALU *) + | "__builtin_k1_addhp", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Paddhp(r, a1, a2))) + | "__builtin_k1_adds", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Padds(r, a1, a2))) + | "__builtin_k1_bwlu", [BA(IR a1); BA(IR a2); BA(IR a3); BA(IR a4); BA(IR a5)], BR(IR r) -> + emit (PExpand (Pbwlu(r, a1, a2, a3, a4, a5))) + | "__builtin_k1_bwluhp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> + emit (PExpand (Pbwluhp(r, a1, a2, a3))) + | "__builtin_k1_bwluwp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> + emit (PExpand (Pbwluwp(r, a1, a2, a3))) + | "__builtin_k1_cbs", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pcbs(r, a1))) + | "__builtin_k1_cbsdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pcbsdl(r, a1))) + | "__builtin_k1_clz", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclz(r, a1))) + | "__builtin_k1_clzw", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzw(r, a1))) + | "__builtin_k1_clzd", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzd(r, a1))) + | "__builtin_k1_clzdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzdl(r, a1))) + | "__builtin_k1_cmove", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> + emit (PExpand (Pcmove(r, a1, a2, a3))) + | "__builtin_k1_ctz", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctz(r, a1))) + | "__builtin_k1_ctzw", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzw(r, a1))) + | "__builtin_k1_ctzd", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzd(r, a1))) + | "__builtin_k1_ctzdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzdl(r, a1))) + | "__builtin_k1_extfz", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> + emit (PExpand (Pextfz(r, a1, a2, a3))) + | "__builtin_k1_landhp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> + emit (PExpand (Plandhp(r, a1, a2, a3))) + | "__builtin_k1_sat", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psat(r, a1, a2))) + | "__builtin_k1_satd", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psatd(r, a1, a2))) + | "__builtin_k1_sbfhp", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbfhp(r, a1, a2))) + | "__builtin_k1_sbmm8", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbmm8(r, a1, a2))) + | "__builtin_k1_sbmmt8", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbmmt8(r, a1, a2))) + | "__builtin_k1_sllhps", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psllhps(r, a1, a2))) + | "__builtin_k1_srahps", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psrahps(r, a1, a2))) + | "__builtin_k1_stsu", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pstsu(r, a1, a2))) + | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pstsud(r, a1, a2))) + (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a - | "__builtin_clzll", [BA(IR a)], BR(IR res) -> - emit (PExpand (Pclzll(res, a))) - | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> - emit (PExpand (Pstsud(res, a1, a2))) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> expand_bswap16 res a1 diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index b478f9b3..a5bdaa28 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -21,13 +21,75 @@ let builtins = { Builtins.typedefs = [ "__builtin_va_list", TPtr(TVoid [], []) ]; - Builtins.functions = [ - "__builtin_clzll", - (TInt(IInt, []), - [TInt(IULongLong, [])], false); - "__builtin_k1_stsud", - (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IULongLong, [])], false); + (* 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?) *) + (* BCU Instructions *) + "__builtin_k1_await", (TVoid [], [], false); + "__builtin_k1_barrier", (TVoid [], [], false); + "__builtin_k1_doze", (TVoid [], [], false); + (* No __builtin_k1_get - not compatible with the Asm model *) + "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); + "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); + "__builtin_k1_invaldtlb", (TVoid [], [], false); + "__builtin_k1_invalitlb", (TVoid [], [], false); + "__builtin_k1_probetlb", (TVoid [], [], false); + "__builtin_k1_readtlb", (TVoid [], [], false); + "__builtin_k1_sleep", (TVoid [], [], false); + "__builtin_k1_stop", (TVoid [], [], false); + "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); + "__builtin_k1_tlbwrite", (TVoid [], [], false); + + (* LSU Instructions *) + (* No ACWS - __int128 *) + "__builtin_k1_afda", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_k1_aldc", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_dinval", (TVoid [], [], false); + "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_fence", (TVoid [], [], false); + "__builtin_k1_iinval", (TVoid [], [], false); + "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lhsu", (TInt(IShort, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lhzu", (TInt(IUShort, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); + + (* ALU Instructions *) + (* "__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, []), + [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUShort, [])], false); *) + (* "__builtin_k1_bwluhp", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_bwluwp", (TInt(IULongLong, []), + [TInt(IULongLong, []); TInt(IULongLong, []); TInt(IUInt, [])], false); *) + (* "__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_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); *) + "__builtin_k1_ctzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_k1_ctzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + (* "__builtin_k1_ctzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_k1_extfz", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_landhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_k1_sat", (TInt(IInt, []), [TInt(IInt, []); TInt(IUChar, [])], false); *) + "__builtin_k1_satd", (TInt(ILongLong, []), [TInt(ILongLong, []); TInt(IUChar, [])], false); + (* "__builtin_k1_sbfhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + "__builtin_k1_sbmm8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + "__builtin_k1_sbmmt8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + (* "__builtin_k1_sllhps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_srahps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_stsu", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + "__builtin_k1_stsud", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + + (* Synchronization *) (* "__builtin_fence", (TVoid [], [], false); diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 41ea06e4..f3babcd6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -223,8 +223,121 @@ module Target : TARGET = end (* Pseudo-instructions not generated by Asmgen *) - | Pclzll(rd, rs) -> + (* BCU instructions *) + | Pawait -> + fprintf oc " await \n;;\n" + | Pbarrier -> + fprintf oc " barrier \n;;\n" + | Pdoze -> + fprintf oc " doze \n;;\n" + | Pwfxl(rs1, rs2) -> + fprintf oc " wfxl %a, %a\n;;\n" ireg rs1 ireg rs2 + | Pwfxm(rs1, rs2) -> + fprintf oc " wfxm %a, %a\n;;\n" ireg rs1 ireg rs2 + | Pinvaldtlb -> + fprintf oc " invaldtlb \n;;\n" + | Pinvalitlb -> + fprintf oc " invalitlb \n;;\n" + | Pprobetlb -> + fprintf oc " probetlb \n;;\n" + | Preadtlb -> + fprintf oc " readtlb \n;;\n" + | Psleep -> + fprintf oc " sleep \n;;\n" + | Pstop -> + fprintf oc " stop \n;;\n" + | Psyncgroup(rs) -> + fprintf oc " syncgroup %a\n;;\n" ireg rs + | Ptlbwrite -> + fprintf oc " tlbwrite \n;;\n" + + (* LSU instructions *) + | Pafda(rd, rs1, rs2) -> + fprintf oc " afda %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Paldc(rd, rs1) -> + fprintf oc " aldc %a = %a\n;;\n" ireg rd ireg rs1 + | Pdinval -> + fprintf oc " dinval \n;;\n" + | Pdinvall (rs) -> + fprintf oc " dinvall %a\n;;\n" ireg rs + | Pdtouchl (rs) -> + fprintf oc " dtouchl %a\n;;\n" ireg rs + | Pdzerol (rs) -> + fprintf oc " dzerol %a\n;;\n" ireg rs + | Pfence -> + fprintf oc " fence \n;;\n" + | Piinval -> + fprintf oc " iinval \n;;\n" + | Piinvals (rs) -> + fprintf oc " iinvals %a\n;;\n" ireg rs + | Pitouchl (rs) -> + fprintf oc " itouchl %a\n;;\n" ireg rs + | Plbsu(rd, rs1) -> + fprintf oc " lbsu %a = %a\n;;\n" ireg rd ireg rs1 + | Plbzu(rd, rs1) -> + fprintf oc " lbzu %a = %a\n;;\n" ireg rd ireg rs1 + | Pldu(rd, rs1) -> + fprintf oc " ldu %a = %a\n;;\n" ireg rd ireg rs1 + | Plhsu(rd, rs1) -> + fprintf oc " lhsu %a = %a\n;;\n" ireg rd ireg rs1 + | Plhzu(rd, rs1) -> + fprintf oc " lhzu %a = %a\n;;\n" ireg rd ireg rs1 + | Plwzu(rd, rs1) -> + fprintf oc " lwzu %a = %a\n;;\n" ireg rd ireg rs1 + + (* ALU instructions *) + | Paddhp(rd, rs1, rs2) -> + fprintf oc " addhp %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Padds(rd, rs1, rs2) -> + fprintf oc " adds %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pbwlu(rd, rs1, rs2, rs3, rs4, rs5) -> + fprintf oc " bwlu %a = %a, %a, %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 ireg rs4 ireg rs5 + | Pbwluhp(rd, rs1, rs2, rs3) -> + fprintf oc " bwluhp %a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 + | Pbwluwp(rd, rs1, rs2, rs3) -> + fprintf oc " bwluwp %a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 + | Pcbs(rd, rs) -> + fprintf oc " cbs %a = %a\n;;\n" ireg rd ireg rs + | Pcbsdl(rd, rs) -> + fprintf oc " cbsdl %a = %a\n;;\n" ireg rd ireg rs + | Pclz(rd, rs) -> + fprintf oc " clz %a = %a\n;;\n" ireg rd ireg rs + | Pclzw(rd, rs) -> + fprintf oc " clzw %a = %a\n;;\n" ireg rd ireg rs + | Pclzd(rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs + | Pclzdl(rd, rs) -> + fprintf oc " clzdl %a = %a\n;;\n" ireg rd ireg rs + | Pcmove(rd, rs1, rs2, rs3) -> + fprintf oc " cmove %a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 + | Pctz(rd, rs) -> + fprintf oc " ctz %a = %a\n;;\n" ireg rd ireg rs + | Pctzw(rd, rs) -> + fprintf oc " ctzw %a = %a\n;;\n" ireg rd ireg rs + | Pctzd(rd, rs) -> + fprintf oc " ctzd %a = %a\n;;\n" ireg rd ireg rs + | Pctzdl(rd, rs) -> + fprintf oc " ctzdl %a = %a\n;;\n" ireg rd ireg rs + | Pextfz(rd, rs1, rs2, rs3) -> + fprintf oc " extfz %a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 + | Plandhp(rd, rs1, rs2, rs3) -> + fprintf oc " landhp %a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 + | Psat(rd, rs1, rs2) -> + fprintf oc " sat %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psatd(rd, rs1, rs2) -> + fprintf oc " satd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psbfhp(rd, rs1, rs2) -> + fprintf oc " sbfhp %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psbmm8(rd, rs1, rs2) -> + fprintf oc " sbmm8 %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psbmmt8(rd, rs1, rs2) -> + fprintf oc " sbmmt8 %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psllhps(rd, rs1, rs2) -> + fprintf oc " sllhps %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrahps(rd, rs1, rs2) -> + fprintf oc " srahps %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pstsu(rd, rs1, rs2) -> + fprintf oc " stsu %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pstsud(rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 -- cgit From 0236781c3ff798b60c5c8171a0f9b6cd569f7995 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 24 May 2018 15:06:18 +0200 Subject: Machblock: Mach language with basic blocks --- mppa_k1c/Machblock.v | 354 ++++++++++++++++++++ mppa_k1c/Machblockgen.v | 749 +++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Machblockgenproof.v | 638 ++++++++++++++++++++++++++++++++++++ 3 files changed, 1741 insertions(+) create mode 100644 mppa_k1c/Machblock.v create mode 100644 mppa_k1c/Machblockgen.v create mode 100644 mppa_k1c/Machblockgenproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v new file mode 100644 index 00000000..9b36fc43 --- /dev/null +++ b/mppa_k1c/Machblock.v @@ -0,0 +1,354 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. + +(** instructions "basiques" (ie non 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 + | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + . + +Definition bblock_body := list basic_inst. + +(** instructions de control flow *) +Inductive control_flow_inst: Type := + | MBcall: signature -> mreg + ident -> control_flow_inst + | MBtailcall: signature -> mreg + ident -> control_flow_inst + | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst + | MBgoto: label -> control_flow_inst + | MBcond: condition -> list mreg -> label -> control_flow_inst + | MBjumptable: mreg -> list label -> control_flow_inst + | MBreturn: control_flow_inst + . + +Record bblock := mk_bblock { + header: option label; + body: bblock_body; + exit: option control_flow_inst +}. + +Lemma bblock_eq: + forall b1 b2, + header b1 = header b2 -> + body b1 = body b2 -> + exit b1 = exit b2 -> + b1 = b2. +Proof. + intros. destruct b1. destruct b2. + simpl in *. subst. auto. +Qed. + +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +Definition size (b:bblock): nat := (length_opt (header b))+(length (body b))+(length_opt (exit b)). + +Lemma size_null b: + size b = 0%nat -> + header b = None /\ body b = nil /\ exit b = None. +Proof. + destruct b as [h b e]. simpl. unfold size. simpl. + intros H. + assert (length_opt h = 0%nat) as Hh; [ omega |]. + assert (length b = 0%nat) as Hb; [ omega |]. + assert (length_opt e = 0%nat) as He; [ omega|]. + repeat split. + destruct h; try (simpl in Hh; discriminate); auto. + destruct b; try (simpl in Hb; discriminate); auto. + destruct e; try (simpl in He; discriminate); auto. +Qed. + +Definition code := list bblock. + +Record function: Type := mkfunction + { fn_sig: signature; + fn_code: code; + fn_stacksize: Z; + fn_link_ofs: ptrofs; + fn_retaddr_ofs: ptrofs }. + +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef unit. + +Definition genv := Genv.t fundef unit. + +(*** sémantique ***) + +Definition is_label (lbl: label) (bb: bblock) : bool := + match header bb with + | Some lbl' => if peq lbl lbl' then true else false + | _ => false + end. + +Lemma is_label_correct: + forall lbl bb, + if is_label lbl bb then (header bb) = Some lbl else (header bb) <> Some lbl. +Proof. + intros. unfold is_label. destruct (header bb) as [lbl'|]; simpl; try discriminate. + case (peq lbl lbl'); intro; congruence. +Qed. + +Local Open Scope nat_scope. + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 + then let bb' := {| header := None ; body := body bb1 ; exit := exit bb1 |} in ( + Some (match size bb' with + | O => bbl + | Datatypes.S _ => bb' :: bbl + end) + ) + else find_label lbl bbl + end. + +Section RELSEM. + +Variable rao:function -> code -> ptrofs -> Prop. +Variable ge:genv. + +Definition find_function_ptr + (ge: genv) (ros: mreg + ident) (rs: regset) : option block := + match ros with + | inl r => + match rs r with + | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None + | _ => None + end + | inr symb => + Genv.find_symbol ge symb + end. + +(** Machblock execution states. *) + +Inductive stackframe: Type := + | Stackframe: + forall (f: block) (**r pointer to calling function *) + (sp: val) (**r stack pointer in calling function *) + (retaddr: val) (**r Asm return address in calling function *) + (c: code), (**r program point in calling function *) + stackframe. + +Inductive state: Type := + | State: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to current function *) + (sp: val) (**r stack pointer *) + (c: code) (**r current program point *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Callstate: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to function to call *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Returnstate: + forall (stack: list stackframe) (**r call stack *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state. + +Definition parent_sp (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => sp + end. + +Definition parent_ra (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => ra + end. + +Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := + | exec_MBgetstack: + forall ofs ty dst v, + load_stack m sp ty ofs = Some v -> + basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m + | exec_MBsetstack: + forall src ofs ty m' rs', + store_stack m sp ty ofs (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_setstack ty) rs -> + basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' + | exec_MBgetparam: + forall ofs ty dst v rs' f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> + rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> + basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m + | exec_MBop: + forall op args v rs' res, + eval_operation ge sp op rs##args m = Some v -> + 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, + 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 + | exec_MBstore: + forall chunk addr args src m' a rs', + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_store chunk addr) rs -> + basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' + . + + +Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := + | exec_nil_body: + forall rs m, + body_step s f sp nil rs m rs m + | exec_cons_body: + forall rs m bi p rs' m' rs'' m'', + basic_step s f sp rs m bi rs' m' -> + body_step s f sp p rs' m' rs'' m'' -> + body_step s f sp (bi::p) rs m rs'' m'' + . + +Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := + | exec_MBcall: + forall s fb sp sig ros c b rs m f f' ra, + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + rao f c ra -> + cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) + E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) + f' rs m) + | exec_MBtailcall: + forall s fb stk soff sig ros c rs m f f' m', + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) + E0 (Callstate s f' rs m') + | exec_MBbuiltin: + forall s f sp rs m ef args res b c vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> + cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) + t (State s f sp c rs' m') + | exec_MBgoto: + forall s fb f sp lbl c rs m c', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + cfi_step (MBgoto lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs m) + | exec_MBcond_true: + forall s fb f sp cond args lbl c rs m c' rs', + eval_condition cond rs##args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBcond_false: + forall s f sp cond args lbl b c rs m rs', + eval_condition cond rs##args m = Some false -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) + E0 (State s f sp c rs' m) + | exec_MBjumptable: + forall s fb f sp arg tbl c rs m n lbl c' rs', + rs arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs destroyed_by_jumptable rs -> + cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBreturn: + forall s fb stk soff c rs m f m', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) + E0 (Returnstate s rs m') + . + +Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := + | exec_Some_exit: + forall ctl s t s', + cfi_step ctl s t s' -> + exit_step (Some ctl) s t s' + | exec_None_exit: + forall stk f sp b lb rs m, + exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) + . + +Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall sf f sp bb c rs m rs' m' t s', + body_step sf f sp (body bb) rs m rs' m' -> + exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> + step (State sf f sp (bb::c) rs m) t s' + | exec_function_internal: + forall s fb rs m f m1 m2 m3 stk rs', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + let sp := Vptr stk Ptrofs.zero in + store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + rs' = undef_regs destroyed_at_function_entry rs -> + step (Callstate s fb rs m) + E0 (State s fb sp f.(fn_code) rs' m3) + | exec_function_external: + forall s fb rs m t rs' ef args res m', + Genv.find_funct_ptr ge fb = Some (External ef) -> + extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> + external_call ef ge args m t res m' -> + rs' = set_pair (loc_result (ef_sig ef)) res rs -> + step (Callstate s fb rs m) + t (Returnstate s rs' m') + | exec_return: + forall s f sp ra c rs m, + step (Returnstate (Stackframe f sp ra c :: s) rs m) + E0 (State s f sp c rs m) + . + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall fb m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some fb -> + initial_state p (Callstate nil fb (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r retcode, + loc_result signature_main = One r -> + rs r = Vint retcode -> + final_state (Returnstate nil rs m) retcode. + +Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := + Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v new file mode 100644 index 00000000..93284b0b --- /dev/null +++ b/mppa_k1c/Machblockgen.v @@ -0,0 +1,749 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. + +Definition to_basic_inst(i: Mach.instruction): option basic_inst := + match i with + | Mgetstack ofs ty dst => Some (MBgetstack ofs ty dst) + | Msetstack src ofs ty => Some (MBsetstack src ofs ty) + | Mgetparam ofs ty dst => Some (MBgetparam ofs ty dst) + | Mop op args res => Some (MBop op args res) + | Mload chunk addr args dst => Some (MBload chunk addr args dst) + | Mstore chunk addr args src => Some (MBstore chunk addr args src) + | _ => None + end. + +(* version pas récursive terminale, mais plus facile pour la preuve *) +Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code := + match c with + | nil => (nil,nil) + | i::c' => + match to_basic_inst i with + | Some bi => + let (p,c'') := to_bblock_body c' in + (bi::p, c'') + | None => (nil, c) + end + end. + +Definition to_bblock_header (c: Mach.code): option label * Mach.code := + match c with + | (Mlabel l)::c' => (Some l, c') + | _ => (None, c) + end. + + +Definition to_cfi (i: Mach.instruction): option control_flow_inst := + match i with + | Mcall sig ros => Some (MBcall sig ros) + | Mtailcall sig ros => Some (MBtailcall sig ros) + | Mbuiltin ef args res => Some (MBbuiltin ef args res) + | Mgoto lbl => Some (MBgoto lbl) + | Mcond cond args lbl => Some (MBcond cond args lbl) + | Mjumptable arg tbl => Some (MBjumptable arg tbl) + | Mreturn => Some (MBreturn) + | _ => None + end. + +Definition to_bblock_exit (c: Mach.code): option control_flow_inst * Mach.code := + match c with + | nil => (None,nil) + | i::c' => + match to_cfi i with + | Some bi as o => (o, c') + | None => (None, c) + end + end. + +Inductive code_nature: Set := IsEmpty | IsLabel | IsBasicInst | IsCFI. + +Definition get_code_nature (c: Mach.code): code_nature := + match c with + | nil => IsEmpty + | (Mlabel _)::_ => IsLabel + | i::_ => match to_basic_inst i with + | Some _ => IsBasicInst + | None => IsCFI + end + end. + +Ltac Discriminate := + match goal with + | [ H: ?a <> ?a |- _ ] => contradict H; auto + | _ => discriminate + end. + + +Lemma cn_eqdec (cn1 cn2: code_nature): { cn1=cn2 } + {cn1 <> cn2}. +Proof. + decide equality. +Qed. + +Lemma get_code_nature_nil c: c<>nil -> get_code_nature c <> IsEmpty. +Proof. + intro. unfold get_code_nature. destruct c; try Discriminate. + destruct i; discriminate. +Qed. + +Lemma get_code_nature_nil_contra c: get_code_nature c = IsEmpty -> c = nil. +Proof. + intro. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. + intro. contradict H0. +Qed. + +Lemma get_code_nature_basic_inst: + forall c a c0, + c = a :: c0 -> + get_code_nature c = IsBasicInst -> + to_basic_inst a <> None. +Proof. + intros. destruct a; discriminate || contradict H0; subst; simpl; discriminate. +Qed. + +Lemma to_bblock_header_not_IsLabel: + forall c b c0, + get_code_nature c <> IsLabel -> + to_bblock_header c = (b, c0) -> + c = c0 /\ b=None. +Proof. + intros. destruct c. + - simpl in H0; inversion H0; auto. + - destruct i; unfold to_bblock_header in H0; inversion H0; auto. + simpl in H; contradict H; auto. +Qed. + + +Lemma to_bblock_header_eq: + forall c b c0, + get_code_nature c <> IsLabel -> + to_bblock_header c = (b, c0) -> + c = c0. +Proof. + intros; exploit to_bblock_header_not_IsLabel; intuition eauto. +Qed. + +Lemma to_bblock_header_IsLabel: + forall c c0 b, + get_code_nature c = IsLabel -> + to_bblock_header c = (b, c0) -> + exists l, c = (Mlabel l)::c0. +Proof. + intros. destruct c; try discriminate. + destruct i; try discriminate. + unfold to_bblock_header in H0; inversion H0; eauto. +Qed. + +Lemma to_bblock_header_wf: + forall c b c0, + get_code_nature c = IsLabel -> + to_bblock_header c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros; exploit to_bblock_header_IsLabel; eauto. + intros [l H1]; subst; simpl; auto. +Qed. + +Ltac ExploitHeaderEq := + match goal with + | [ H: to_bblock_header (?i0 :: ?c) = (?b, ?c0) |- _ ] => + exploit (to_bblock_header_eq (i0::c) b c0); [subst; simpl; discriminate | auto | intro; subst; auto] + | _ => idtac + end. + +Lemma to_bblock_header_wfe: + forall c b c0, + to_bblock_header c = (b, c0) -> + (length c >= length c0)%nat. +Proof. + intros c b c0; destruct (cn_eqdec (get_code_nature c) IsLabel). + - intros; exploit to_bblock_header_wf; eauto; omega. + - intros; exploit to_bblock_header_eq; eauto. intros; subst; auto. +Qed. + +Lemma to_bblock_body_eq: + forall c b c0, + get_code_nature c <> IsBasicInst -> + to_bblock_body c = (b, c0) -> + c = c0. +Proof. + intros. destruct c. + - simpl in H0. inversion H0. auto. + - destruct i; simpl in *; try Discriminate || inversion H0; subst; auto. +Qed. + +Lemma to_bblock_body_wfe: + forall c b c0, + to_bblock_body c = (b, c0) -> + (length c >= length c0)%nat. +Proof. + induction c. + - intros. simpl in H. inversion H. subst. auto. + - intros. simpl in H. destruct (to_basic_inst a). + + remember (to_bblock_body c) as tbbc. destruct tbbc as [p c'']. + exploit (IHc p c''); auto. inversion H. subst. simpl. omega. + + inversion H; subst; auto. +Qed. + + +Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := + Cons_to_bbloc_body i bi c' b': + to_basic_inst i = Some bi + -> to_bblock_body c' = (b', c0) + -> cons_to_bblock_body c0 (i::c') (bi::b'). + +Lemma to_bblock_body_IsBasicInst: + forall c b c0, + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + cons_to_bblock_body c0 c b. +Proof. + intros. destruct c; [ contradict H; simpl; discriminate | ]. + remember (to_basic_inst i) as tbii. destruct tbii. + - simpl in H0. rewrite <- Heqtbii in H0. + remember (to_bblock_body c) as tbbc. destruct tbbc as [p1 c1]. + inversion H0. subst. eapply Cons_to_bbloc_body; eauto. + - destruct i; try discriminate. +Qed. + +Lemma to_bblock_body_wf: + forall c b c0, + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros; exploit to_bblock_body_IsBasicInst; eauto. + intros H1; destruct H1. + exploit to_bblock_body_wfe; eauto. + simpl; omega. +Qed. + +Lemma to_bblock_exit_eq: + forall c b c0, + get_code_nature c <> IsCFI -> + to_bblock_exit c = (b, c0) -> + c = c0. +Proof. + intros. destruct c. + - simpl in H0; inversion H0; auto. + - destruct i; unfold to_bblock_header in H0; inversion H0; auto; + simpl in H; contradict H; auto. +Qed. + +Lemma to_bblock_exit_wf: + forall c b c0, + get_code_nature c = IsCFI -> + to_bblock_exit c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros. destruct c; try discriminate. + destruct i; try discriminate; + unfold to_bblock_header in H0; inversion H0; auto. +Qed. + +Ltac ExploitExitEq := + match goal with + | [ H: to_bblock_exit (?i0 :: ?c) = (?b, ?c0) |- _ ] => + exploit (to_bblock_exit_eq (i0::c) b c0); [subst; simpl; discriminate | auto | intro; subst; auto] + | _ => idtac + end. + +Lemma to_bblock_exit_wfe: + forall c b c0, + to_bblock_exit c = (b, c0) -> + (length c >= length c0)%nat. +Proof. + intros. destruct c. unfold to_bblock_exit in H; inversion H; auto. + remember i as i0. + destruct i; try ExploitExitEq. + all: exploit (to_bblock_exit_wf (i0::c) b c0); [subst; simpl; auto | auto | try omega]. +Qed. + +Definition to_bblock(c: Mach.code): bblock * Mach.code := + let (h,c0) := to_bblock_header c in + let (bdy, c1) := to_bblock_body c0 in + let (ext, c2) := to_bblock_exit c1 in + ({| header := h; body := bdy; exit := ext |}, c2) + . + +Lemma to_bblock_double_label: + forall c l, + get_code_nature c = IsLabel -> + to_bblock (Mlabel l :: c) = ({| header := Some l; body := nil; exit := None |}, c). +Proof. + intros. + destruct c; try (contradict H; simpl; discriminate). + destruct i; try (contradict H; simpl; discriminate). + simpl. auto. +Qed. + +Lemma to_bblock_basic_inst_then_label: + forall i c bi, + get_code_nature (i::c) = IsBasicInst -> + get_code_nature c = IsLabel -> + to_basic_inst i = Some bi -> + fst (to_bblock (i::c)) = {| header := None; body := bi::nil; exit := None |}. +Proof. + intros. + destruct c; try (contradict H; simpl; discriminate). + destruct i0; try (contradict H; simpl; discriminate). + destruct i; simpl in *; inversion H1; subst; auto. +Qed. + +Lemma to_bblock_cf_inst_then_label: + forall i c cfi, + get_code_nature (i::c) = IsCFI -> + get_code_nature c = IsLabel -> + to_cfi i = Some cfi -> + fst (to_bblock (i::c)) = {| header := None; body := nil; exit := Some cfi |}. +Proof. + intros. + destruct c; try (contradict H; simpl; discriminate). + destruct i0; try (contradict H; simpl; discriminate). + destruct i; simpl in *; inversion H1; subst; auto. +Qed. + +Lemma to_bblock_single_label: + forall c l, + get_code_nature c <> IsLabel -> + fst (to_bblock (Mlabel l :: c)) = {| + header := Some l; + body := body (fst (to_bblock c)); + exit := exit (fst (to_bblock c)) + |}. +Proof. + intros. + destruct c; simpl; auto. + apply bblock_eq; simpl. +(* header *) + + destruct i; try ( + remember (to_bblock _) as bb; + unfold to_bblock in *; + remember (to_bblock_header _) as tbh; + destruct tbh; + destruct (to_bblock_body _); + destruct (to_bblock_exit _); + subst; simpl; inversion Heqtbh; auto; fail + ). +(* body *) + + remember i as i0; destruct i0; try ( + remember (to_bblock _) as bb; + unfold to_bblock in *; + remember (to_bblock_header _) as tbh; rewrite Heqi0; + remember (to_bblock_header (i :: _)) as tbh'; rewrite <- Heqi0 in *; + destruct tbh; destruct tbh'; + inversion Heqtbh; inversion Heqtbh'; subst; + destruct (to_bblock_body _); + destruct (to_bblock_exit _); auto; fail + ). contradict H; simpl; auto. +(* exit (same proof as body) *) + + remember i as i0; destruct i0; try ( + remember (to_bblock _) as bb; + unfold to_bblock in *; + remember (to_bblock_header _) as tbh; rewrite Heqi0; + remember (to_bblock_header (i :: _)) as tbh'; rewrite <- Heqi0 in *; + destruct tbh; destruct tbh'; + inversion Heqtbh; inversion Heqtbh'; subst; + destruct (to_bblock_body _); + destruct (to_bblock_exit _); auto; fail + ). contradict H; simpl; auto. +Qed. + +Lemma to_bblock_no_label: + forall c, + get_code_nature c <> IsLabel -> + fst (to_bblock c) = {| + header := None; + body := body (fst (to_bblock c)); + exit := exit (fst (to_bblock c)) + |}. +Proof. + intros. + destruct c; simpl; auto. + apply bblock_eq; simpl; + destruct i; ( + try ( + remember (to_bblock _) as bb; + unfold to_bblock in *; + remember (to_bblock_header _) as tbh; + destruct tbh; + destruct (to_bblock_body _); + destruct (to_bblock_exit _); + subst; simpl; inversion Heqtbh; auto; fail + ) + || contradict H; simpl; auto ). +Qed. + +Lemma to_bblock_body_nil c c': + to_bblock_body c = (nil, c') -> + c = c'. +Proof. + intros H. + destruct c; [ simpl in *; inversion H; auto |]. + destruct i; try ( simpl in *; remember (to_bblock_body c) as tbc; destruct tbc as [p c'']; inversion H ). + all: auto. +Qed. + +Lemma to_bblock_exit_nil c c': + to_bblock_exit c = (None, c') -> + c = c'. +Proof. + intros H. + destruct c; [ simpl in *; inversion H; auto |]. + destruct i; try ( simpl in *; remember (to_bblock_exit c) as tbe; destruct tbe as [p c'']; inversion H ). + all: auto. +Qed. + +Lemma to_bblock_label b l c c': + to_bblock (Mlabel l :: c) = (b, c') -> + exists bdy c1, to_bblock_body c = (bdy, c1) /\ + header b = Some l /\ body b = bdy /\ exit b = fst (to_bblock_exit c1). +Proof. + intros H. + (* destruct b as [bhd bbd bex]. simpl. *) + unfold to_bblock in H; simpl in H. + remember (to_bblock_body c) as tbbc; destruct tbbc as [bdy' c1']. + remember (to_bblock_exit c1') as tbbe; destruct tbbe as [ext c2]. + esplit; eauto. esplit; eauto. esplit; eauto. + inversion H; subst; clear H. simpl. + apply (f_equal fst) in Heqtbbe. simpl in Heqtbbe. auto. +Qed. + +Lemma to_bblock_label_then_nil b l c c': + to_bblock (Mlabel l :: c) = (b, c') -> + body b = nil -> + exit b = None -> + c = c'. +Proof. + intros TOB BB EB. + unfold to_bblock in TOB. + remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. + remember (to_bblock_body _) as tbb; destruct tbb as [bdy c1]. + remember (to_bblock_exit _) as tbe; destruct tbe as [ext c2]. + inversion TOB; subst. simpl in *. clear TOB. + inversion Heqtbh; subst. clear Heqtbh. + exploit to_bblock_body_nil; eauto. intros; subst. clear Heqtbb. + exploit to_bblock_exit_nil; eauto. +Qed. + +Lemma to_bblock_basic_inst: + forall c i bi, + get_code_nature (i::c) = IsBasicInst -> + to_basic_inst i = Some bi -> + get_code_nature c <> IsLabel -> + fst (to_bblock (i::c)) = {| + header := None; + body := bi :: body (fst (to_bblock c)); + exit := exit (fst (to_bblock c)) + |}. +Proof. + intros. + destruct c; try (destruct i; inversion H0; subst; simpl; auto; fail). + apply bblock_eq; simpl. +(* header *) + + destruct i; simpl; auto; ( + exploit to_bblock_no_label; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]). +(* body *) +(* FIXME - the proof takes some time to prove.. N² complexity :( *) + + destruct i; inversion H0; try ( + destruct i0; try ( + subst; unfold to_bblock; + remember (to_bblock_header _) as tbh; destruct tbh; + remember (to_bblock_header (_::c)) as tbh'; destruct tbh'; + inversion Heqtbh; inversion Heqtbh'; subst; + + remember (to_bblock_body _) as tbb; destruct tbb; + remember (to_bblock_body (_::c)) as tbb'; destruct tbb'; + inversion Heqtbb; inversion Heqtbb'; destruct (to_bblock_body c); + inversion H3; inversion H4; subst; + + remember (to_bblock_exit _) as tbc; destruct tbc; + simpl; auto ); + contradict H1; simpl; auto ). +(* exit - same as body *) + + destruct i; inversion H0; try ( + destruct i0; try ( + subst; unfold to_bblock; + remember (to_bblock_header _) as tbh; destruct tbh; + remember (to_bblock_header (_::c)) as tbh'; destruct tbh'; + inversion Heqtbh; inversion Heqtbh'; subst; + + remember (to_bblock_body _) as tbb; destruct tbb; + remember (to_bblock_body (_::c)) as tbb'; destruct tbb'; + inversion Heqtbb; inversion Heqtbb'; destruct (to_bblock_body c); + inversion H3; inversion H4; subst; + + remember (to_bblock_exit _) as tbc; destruct tbc; + simpl; auto ); + contradict H1; simpl; auto ). +Qed. + +Lemma to_bblock_size_single_label: + forall c i, + get_code_nature (i::c) = IsLabel -> + get_code_nature c <> IsLabel -> + size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). +Proof. + intros. + destruct i; try (contradict H; simpl; discriminate). + destruct c; simpl; auto. + destruct i; try ( + exploit to_bblock_single_label; eauto; intro; rewrite H1; + exploit to_bblock_no_label; eauto; intro; rewrite H2; + simpl; auto; fail ). + Unshelve. all: auto. +Qed. + +Lemma to_bblock_size_label_neqz: + forall c, + get_code_nature c = IsLabel -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros. destruct c; try (contradict H; auto; simpl; discriminate). + destruct i; try (contradict H; simpl; discriminate). + destruct (get_code_nature c) eqn:gcnc. + (* Case gcnc is not IsLabel *) + all: try (rewrite to_bblock_size_single_label; auto; rewrite gcnc; discriminate). + (* Case gcnc is IsLabel *) + rewrite to_bblock_double_label; auto; unfold size; simpl; auto. +Qed. + +Lemma to_bblock_size_basicinst_neqz: + forall c, + get_code_nature c = IsBasicInst -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros. destruct c; try (contradict H; auto; simpl; discriminate). + destruct i; try (contradict H; simpl; discriminate); + ( + destruct (get_code_nature c) eqn:gcnc; + (* Case gcnc is not IsLabel *) + try (erewrite to_bblock_basic_inst; eauto; [ + unfold size; simpl; auto + | simpl; auto + | rewrite gcnc; discriminate + ]); + erewrite to_bblock_basic_inst_then_label; eauto; [ + unfold size; simpl; auto + | simpl; auto + ] + ). +Qed. + +Lemma to_bblock_size_cfi_neqz: + forall c, + get_code_nature c = IsCFI -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros. destruct c; try (contradict H; auto; simpl; discriminate). + destruct i; discriminate. +Qed. + +Lemma to_bblock_size_single_basicinst: + forall c i, + get_code_nature (i::c) = IsBasicInst -> + get_code_nature c <> IsLabel -> + size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). +Proof. + intros. + destruct i; try (contradict H; simpl; discriminate); try ( + (exploit to_bblock_basic_inst; eauto); + [remember (to_basic_inst _) as tbi; destruct tbi; eauto |]; + intro; rewrite H1; unfold size; simpl; + assert ((length_opt (header (fst (to_bblock c)))) = 0%nat); + exploit to_bblock_no_label; eauto; intro; rewrite H2; simpl; auto; + rewrite H2; auto + ). +Qed. + +Lemma to_bblock_wf c b c0: + c <> nil -> + to_bblock c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intro H; lapply (get_code_nature_nil c); eauto. + intro H'; remember (get_code_nature c) as gcn. + unfold to_bblock. + remember (to_bblock_header c) as p1; eauto. + destruct p1 as [h c1]. + intro H0. + destruct gcn. + - contradict H'; auto. + - exploit to_bblock_header_wf; eauto. + remember (to_bblock_body c1) as p2; eauto. + destruct p2 as [h2 c2]. + exploit to_bblock_body_wfe; eauto. + remember (to_bblock_exit c2) as p3; eauto. + destruct p3 as [h3 c3]. + exploit to_bblock_exit_wfe; eauto. + inversion H0. omega. + - exploit to_bblock_header_eq; eauto. rewrite <- Heqgcn. discriminate. + intro; subst. + remember (to_bblock_body c1) as p2; eauto. + destruct p2 as [h2 c2]. + exploit to_bblock_body_wf; eauto. + remember (to_bblock_exit c2) as p3; eauto. + destruct p3 as [h3 c3]. + exploit to_bblock_exit_wfe; eauto. + inversion H0. omega. + - exploit to_bblock_header_eq; eauto. rewrite <- Heqgcn. discriminate. + intro; subst. + remember (to_bblock_body c1) as p2; eauto. + destruct p2 as [h2 c2]. + exploit (to_bblock_body_eq c1 h2 c2); eauto. rewrite <- Heqgcn. discriminate. + intro; subst. + remember (to_bblock_exit c2) as p3; eauto. + destruct p3 as [h3 c3]. + exploit (to_bblock_exit_wf c2 h3 c3); eauto. + inversion H0. omega. +Qed. + +Lemma to_bblock_nonil: + forall c i c0, + c = i :: c0 -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros. remember (get_code_nature c) as gcnc. destruct gcnc. + - contradict Heqgcnc. subst. simpl. destruct i; discriminate. + - eapply to_bblock_size_label_neqz; auto. + - eapply to_bblock_size_basicinst_neqz; auto. + - eapply to_bblock_size_cfi_neqz; auto. +Qed. + +Lemma to_bblock_islabel: + forall c l, + is_label l (fst (to_bblock (Mlabel l :: c))) = true. +Proof. + intros. unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. + remember (to_bblock_body _) as tbc; destruct tbc as [bdy c1]. + remember (to_bblock_exit _) as tbe; destruct tbe as [ext c2]. + simpl. inversion Heqtbh. unfold is_label. simpl. + apply peq_true. +Qed. + +Lemma body_fst_to_bblock_label: + forall l c, + body (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_body c). +Proof. + intros. destruct c as [|i c']; simpl; auto. + destruct i; simpl; auto. + all: ( + remember (to_bblock_body c') as tbbc; destruct tbbc as [tc c'']; simpl; + unfold to_bblock; + remember (to_bblock_header _) as tbh; destruct tbh as [h c0]; + remember (to_bblock_body c0) as tbc; destruct tbc as [bdy c1]; + remember (to_bblock_exit c1) as tbe; destruct tbe as [ext c2]; + simpl; simpl in Heqtbh; inversion Heqtbh; subst c0; + simpl in Heqtbc; remember (to_bblock_body c') as tbc'; destruct tbc' as [tc' osef]; + inversion Heqtbc; inversion Heqtbbc; auto + ). +Qed. + +Lemma exit_fst_to_bblock_label: + forall c c' l, + snd (to_bblock_body c) = c' -> + exit (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_exit c'). +Proof. + intros. destruct c as [|i c]; [simpl in *; subst; auto |]. + unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. + remember (to_bblock_body c0) as tbc; destruct tbc as [bdy c1]. + remember (to_bblock_exit c1) as tbe; destruct tbe as [ext c2]. + simpl in *. inversion Heqtbh; subst. + destruct (to_basic_inst i) eqn:TBI. + - remember (to_bblock_body c) as tbbc; destruct tbbc as [p c'']. + simpl. simpl in Heqtbc. rewrite TBI in Heqtbc. rewrite <- Heqtbbc in Heqtbc. + inversion Heqtbc; subst. apply (f_equal fst) in Heqtbe; auto. + - simpl. simpl in Heqtbc. rewrite TBI in Heqtbc. + inversion Heqtbc; subst. clear Heqtbh Heqtbc. unfold to_bblock_exit in Heqtbe. + apply (f_equal fst) in Heqtbe; auto. +Qed. + +Function trans_code (c: Mach.code) { measure length c }: code := + match c with + | nil => nil + | _ => + let (b, c0) := to_bblock c in + b::(trans_code c0) + end. +Proof. + intros; eapply to_bblock_wf; eauto. discriminate. +Qed. + +(* +Functional Scheme trans_code_ind := Induction for trans_code Sort Prop. +*) + +Definition hd_code (bc: code) := (hd {| header := None; body := nil; exit := None |} bc). + +Lemma trans_code_nonil: + forall c, + c <> nil -> trans_code c <> nil. +Proof. + intros. + induction c, (trans_code c) using trans_code_ind; simpl; auto. discriminate. +Qed. + +Lemma trans_code_step: + forall c b lb0 hb c1 bb c2 eb c3, + trans_code c = b :: lb0 -> + to_bblock_header c = (hb, c1) -> + to_bblock_body c1 = (bb, c2) -> + to_bblock_exit c2 = (eb, c3) -> + hb = header b /\ bb = body b /\ eb = exit b /\ trans_code c3 = lb0. +Proof. + intros. + induction c, (trans_code c) using trans_code_ind. discriminate. clear IHc0. + subst. destruct _x as [|i c]; try (contradict y; auto; fail). + inversion H; subst. clear H. unfold to_bblock in e0. + remember (to_bblock_header (i::c)) as hd. destruct hd as [hb' c1']. + remember (to_bblock_body c1') as bd. destruct bd as [bb' c2']. + remember (to_bblock_exit c2') as be. destruct be as [eb' c3']. + inversion e0. simpl. + inversion H0. subst. + rewrite <- Heqbd in H1. inversion H1. subst. + rewrite <- Heqbe in H2. inversion H2. subst. + auto. +Qed. + +Lemma trans_code_cfi: + forall i c cfi, + to_cfi i = Some cfi -> + trans_code (i :: c) = {| header := None ; body := nil ; exit := Some cfi |} :: trans_code c. +Proof. + intros. rewrite trans_code_equation. remember (to_bblock _) as tb; destruct tb as [b c0]. + destruct i; try (contradict H; discriminate). + all: unfold to_bblock in Heqtb; remember (to_bblock_header _) as tbh; destruct tbh as [h c0']; + remember (to_bblock_body c0') as tbb; destruct tbb as [bdy c1']; + remember (to_bblock_exit c1') as tbe; destruct tbe as [ext c2]; simpl in *; + inversion Heqtbh; subst; inversion Heqtbb; subst; inversion Heqtbe; subst; + inversion Heqtb; subst; rewrite H; auto. +Qed. + +(* à finir pour passer des Mach.function au function, etc. *) +Definition trans_function (f: Mach.function) : function := + {| fn_sig:=Mach.fn_sig f; + fn_code:=trans_code (Mach.fn_code f); + fn_stacksize := Mach.fn_stacksize f; + fn_link_ofs := Mach.fn_link_ofs f; + fn_retaddr_ofs := Mach.fn_retaddr_ofs f + |}. + +Definition trans_fundef (f: Mach.fundef) : fundef := + transf_fundef trans_function f. + +Definition trans_prog (src: Mach.program) : program := + transform_program trans_fundef src. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v new file mode 100644 index 00000000..838f7977 --- /dev/null +++ b/mppa_k1c/Machblockgenproof.v @@ -0,0 +1,638 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. +Require Import Machblockgen. +Require Import ForwardSimulationBlock. + +(* FIXME: put this section somewhere else. + In "Smallstep" ? + +TODO: also move "starN_last_step" in the same section ? + +*) + +Section starN_lemma. +(* Auxiliary Lemma on starN *) + +Import Smallstep. +Local Open Scope nat_scope. + + +Variable L: semantics. + +Local Hint Resolve starN_refl starN_step Eapp_assoc. + +Lemma starN_split n s t s': + starN (step L) (globalenv L) n s t s' -> + forall m k, n=m+k -> + exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. +Proof. + induction 1; simpl. + + intros m k H; assert (X: m=0); try omega. + assert (X0: k=0); try omega. + subst; repeat (eapply ex_intro); intuition eauto. + + intros m; destruct m as [| m']; simpl. + - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. + - intros k H2. inversion H2. + exploit (IHstarN m' k); eauto. intro. + destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). + repeat (eapply ex_intro). + instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). + intuition eauto. subst. auto. +Qed. + +End starN_lemma. + + +Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := + rao (trans_function f) (trans_code c). + +Definition match_prog (p: Mach.program) (tp: Machblock.program) := + match_program (fun _ f tf => tf = trans_fundef f) eq p tp. + +Lemma trans_program_match: forall p, match_prog p (trans_prog p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Definition trans_stackframe (msf: Mach.stackframe) : stackframe := + match msf with + | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) + end. + +Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := + match mst with + | nil => nil + | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) + end. + +Definition trans_state (ms: Mach.state) : state := + match ms with + | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m + | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m + | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m + end. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Machblock.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 init_mem_preserved: + forall m, + Genv.init_mem prog = Some m -> + Genv.init_mem tprog = Some m. +Proof (Genv.init_mem_transf TRANSF). + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main 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 /\ trans_fundef f = tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. + destruct H0 as (cunit & tf & A & B & C). + eapply ex_intro. intuition; eauto. subst. eapply A. +Qed. + +Lemma find_function_ptr_same: + forall s rs, + Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. +Proof. + intros. unfold Mach.find_function_ptr. unfold find_function_ptr. + destruct s; auto. + rewrite symbols_preserved; auto. +Qed. + +Lemma find_funct_ptr_same: + forall f f0, + Genv.find_funct_ptr ge f = Some (Internal f0) -> + Genv.find_funct_ptr tge f = Some (Internal (trans_function f0)). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma find_funct_ptr_same_external: + forall f f0, + Genv.find_funct_ptr ge f = Some (External f0) -> + Genv.find_funct_ptr tge f = Some (External f0). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma parent_sp_preserved: + forall s, + Mach.parent_sp s = parent_sp (trans_stack s). +Proof. + unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma parent_ra_preserved: + forall s, + Mach.parent_ra s = parent_ra (trans_stack s). +Proof. + unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma external_call_preserved: + forall ef args m t res m', + external_call ef ge args m t res m' -> + external_call ef tge args m t res m'. +Proof. + intros. eapply external_call_symbols_preserved; eauto. + apply senv_preserved. +Qed. + +Lemma Mach_find_label_split l i c c': + Mach.find_label l (i :: c) = Some c' -> + (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). +Proof. + intros H. + destruct i; try (constructor 2; split; auto; discriminate ). + destruct (peq l0 l) as [P|P]. + - constructor. subst l0; split; auto. + revert H. unfold Mach.find_label. simpl. rewrite peq_true. + intros H; injection H; auto. + - constructor 2. split. + + intro F. injection F. intros. contradict P; auto. + + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. +Qed. + +Lemma find_label_stop l b c c0: + to_bblock (Mlabel l :: c) = (b, c0) -> find_label l (b :: trans_code c0) = Some (trans_code c). +Proof. + intros H. + unfold find_label. + assert (X: b=(fst (to_bblock (Mlabel l :: c)))). + { rewrite H; simpl; auto. } + subst b; rewrite to_bblock_islabel. + remember ({| header := None; body := _ ; exit := _ |}) as b'. + remember (fst (to_bblock _)) as b. + destruct (size b') eqn:SIZE. + - destruct (size_null b') as (Hh & Hb & He); auto. + subst b'; simpl in *. clear Hh SIZE. + erewrite <- (to_bblock_label_then_nil b l c c0); eauto. + - assert (X: exists b0 lb0, trans_code c = b0::lb0 /\ c <> nil). + { induction c, (trans_code c) using trans_code_ind. + + subst. simpl in * |-. inversion SIZE. + + (repeat econstructor 1). intro; subst; try tauto. + } + destruct X as (b0 & lb0 & X0 & X1). + unfold to_bblock in * |-. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + unfold size in SIZE; subst b b'; simpl in * |-. + injection H; clear H; intro; subst c3. + injection Heqbh; clear Heqbh; intros; subst. + cut (to_bblock_header c = (None, c)). + * intros X2; exploit trans_code_step; eauto. + simpl; rewrite X0; clear X0. + intros (Y1 & Y2 & Y3 & Y4). subst. + rewrite Y1; clear X1; destruct b0; simpl; auto. + * destruct (cn_eqdec (get_code_nature c) IsLabel) as [ Y | Y ]. + + destruct c; simpl; try discriminate. + destruct i; simpl; try discriminate. + simpl in * |-. + inversion Heqbb; subst. simpl in * |-. + inversion Heqbe; subst; simpl in * |-. + discriminate. + + destruct c; simpl; discriminate || auto. + destruct i; simpl; auto. + destruct Y. simpl; auto. +Qed. + +Lemma find_label_next l i b c c': + to_bblock (i :: c) = (b, c') -> i <> Mlabel l -> find_label l (b :: trans_code c') = find_label l (trans_code c'). +Proof. + intros H H1. + destruct b as [hd bd ex]. + destruct (cn_eqdec (get_code_nature (i::c)) IsLabel) as [ X | X ]. + - destruct i; try discriminate. + exploit to_bblock_label; eauto. + intros (bdy & c1 & Y1 & Y2 & Y3 & Y4). + simpl in *|-. subst. clear X. + simpl. unfold is_label; simpl. + assert (l0 <> l); [ intro; subst; contradict H1; auto |]. + rewrite peq_false; auto. + - exploit to_bblock_no_label; eauto. + intro Y. apply (f_equal fst) in H as Y1. simpl in Y1. rewrite Y in Y1. clear Y. + inversion Y1; subst; clear Y1. + simpl. auto. +Qed. + +Lemma to_bblock_header_split i c h c1: + to_bblock_header (i::c)=(h, c1) + -> (exists l, i=Mlabel l /\ h=Some l /\ c1=c) \/ (forall l, i<>Mlabel l /\ h=None /\ c1=(i::c)). +Proof. + destruct i; simpl; intros H; inversion H; try (constructor 2; intuition auto; discriminate). + constructor 1; eapply ex_intro; intuition eauto. +Qed. + +Lemma to_bblock_header_find_label i c1 l c h: + i <> Mlabel l + -> to_bblock_header (i :: c) = (h, c1) -> Mach.find_label l c = Mach.find_label l c1. +Proof. + intros H1 H2; exploit to_bblock_header_split; eauto. + intros [ ( l0 & X1 & X2 & X3 ) | X ]. + - subst. auto. + - destruct (X l) as (X1 & X2 & X3). subst. clear X X1. + symmetry. destruct i; try (simpl; auto). + assert (l0 <> l); [ intro; subst; contradict H1; auto |]. + rewrite peq_false; auto. +Qed. + +Lemma to_bblock_body_find_label c2 bdy l c1: + (bdy, c2) = to_bblock_body c1 -> + Mach.find_label l c1 = Mach.find_label l c2. +Proof. + generalize bdy c2. + induction c1 as [|i c1]. + - intros bdy0 c0 H. simpl in H. inversion H; subst; clear H. auto. + - intros bdy' c2' H. simpl in H. destruct i; try ( + simpl in H; remember (to_bblock_body c1) as tbb; destruct tbb as [p c'']; + inversion H; subst; clear H; simpl; erewrite IHc1; eauto; fail). +Qed. + +Lemma to_bblock_exit_find_label c2 ext l c1: + (ext, c2) = to_bblock_exit c1 + -> Mach.find_label l c1 = Mach.find_label l c2. +Proof. + intros H. destruct c1 as [|i c1]. + - simpl in H. inversion H; subst; clear H. auto. + - destruct i; try ( + simpl in H; inversion H; subst; clear H; auto; fail). +Qed. + +Lemma Mach_find_label_to_bblock i c l b c0: + i <> Mlabel l + -> to_bblock (i :: c) = (b, c0) + -> Mach.find_label l c = Mach.find_label l c0. +Proof. + intro H. + unfold to_bblock. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + intros X; injection X. clear X; intros; subst. + erewrite (to_bblock_header_find_label i c1); eauto. + erewrite (to_bblock_body_find_label c2); eauto. + erewrite to_bblock_exit_find_label; eauto. +Qed. + +Local Hint Resolve find_label_next. + +Lemma find_label_transcode_preserved: + forall l c c', + Mach.find_label l c = Some c' -> + find_label l (trans_code c) = Some (trans_code c'). +Proof. + intros l c; induction c, (trans_code c) using trans_code_ind. + - intros c' H; inversion H. + - intros c' H. subst _x. destruct c as [| i c]; try tauto. + exploit Mach_find_label_split; eauto. clear H. + intros [ [H1 H2] | [H1 H2] ]. + + subst. erewrite find_label_stop; eauto. + + rewrite <- IHc0. eauto. + erewrite <- (Mach_find_label_to_bblock i c); eauto. +Qed. + +Lemma find_label_preserved: + forall l f c, + Mach.find_label l (Mach.fn_code f) = Some c -> + find_label l (fn_code (trans_function f)) = Some (trans_code c). +Proof. + intros. cutrewrite ((fn_code (trans_function f)) = trans_code (Mach.fn_code f)); eauto. + apply find_label_transcode_preserved; auto. +Qed. + +Lemma mem_free_preserved: + forall m stk f, + Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (trans_function f)). +Proof. + intros. auto. +Qed. + +Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated + parent_sp_preserved. + +Definition dist_end_block_code (c: Mach.code) := (size (fst (to_bblock c))-1)%nat. + + +Definition dist_end_block (s: Mach.state): nat := + match s with + | Mach.State _ _ _ c _ _ => dist_end_block_code c + | _ => 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. + +Variable rao: function -> code -> ptrofs -> Prop. + +(* +Lemma minus_diff_0 n: (n-1<>0)%nat -> (n >= 2)%nat. +Proof. + omega. +Qed. +*) + +Ltac ExploitDistEndBlockCode := + match goal with + | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => + exploit (to_bblock_size_single_label c (Mlabel l)); eauto + | [ H : dist_end_block_code (?i0 :: ?c) <> 0%nat |- _ ] => + exploit (to_bblock_size_single_basicinst c i0); eauto + | _ => idtac + end. + +(* FIXME - refactoriser avec get_code_nature pour que ce soit plus joli *) +Lemma dist_end_block_code_simu_mid_block i c: + dist_end_block_code (i::c) <> 0%nat -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c))%nat. +Proof. + intros. + remember (get_code_nature c) as gcnc; destruct gcnc. + (* when c is nil *) + - contradict H. rewrite get_code_nature_nil_contra with (c := c); auto. destruct i; simpl; auto. + (* when c is IsLabel *) + - remember i as i0; remember (to_basic_inst i) as sbi; remember (to_cfi i) as scfi; + remember (get_code_nature (i::c)) as gcnic; + destruct i. + (* when i is a basic instruction *) + 1-6: try (( contradict H; unfold dist_end_block_code; exploit to_bblock_basic_inst_then_label; eauto; + [ totologize Heqgcnic; eapply Htoto + | totologize Heqsbi; try eapply Htoto + | intro; subst; rewrite H; simpl; auto + ] ); fail). + (* when i is a control flow instruction *) + 1-8: try (( contradict H; unfold dist_end_block_code; exploit to_bblock_cf_inst_then_label; eauto; + [ totologize Heqgcnic; eapply Htoto + | totologize Heqscfi; try eapply Htoto + | intro; subst; rewrite H; simpl; auto + ] ); fail). + (* when i is a label *) + contradict H. unfold dist_end_block_code. exploit to_bblock_double_label; eauto. + intro. subst. rewrite H. simpl. auto. + (* when c is IsBasicInst or IsCFI *) + - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) + ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | + unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). + - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) + ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | + unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). +Qed. + +Local Hint Resolve dist_end_block_code_simu_mid_block. + +Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): + to_basic_inst i = Some bi -> + Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. +Proof. + destruct i; simpl in * |-; + (discriminate + || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). + - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. + destruct H3 as (tf & A & B). subst. eapply A. + all: simpl; rewrite <- parent_sp_preserved; auto. + - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. + 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_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. +Qed. + + +Lemma star_step_simu_body_step s f sp c: + forall (p:bblock_body) c' rs m t s', + to_bblock_body c = (p, c') -> + starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp p rs m rs' m'. +Proof. + induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. + * (* nil *) + inversion_clear H; simpl; intros X; inversion_clear X. + eapply ex_intro; eapply ex_intro; intuition eauto. + * (* cons *) + remember (to_basic_inst i0) as o eqn:Ho. + destruct o as [bi |]. + + (* to_basic_inst i0 = Some bi *) + remember (to_bblock_body c0) as r eqn:Hr. + destruct r as [p1 c1]; inversion H; simpl; subst; clear H. + intros X; inversion_clear X. + exploit step_simu_basic_step; eauto. + intros [rs' [m' [H2 [H3 H4]]]]; subst. + exploit Hc0; eauto. + intros [rs'' [m'' [H5 [H6 H7]]]]; subst. + refine (ex_intro _ rs'' (ex_intro _ m'' _)); intuition eauto. + + (* to_basic_inst i0 = None *) + inversion_clear H; simpl. + intros X; inversion_clear X. intuition eauto. +Qed. + +Lemma step_simu_cfi_step: + forall c e c' stk f sp rs m t s' b lb', + to_bblock_exit c = (Some e, c') -> + trans_code c' = lb' -> + Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp c rs m) t s' -> + cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t (trans_state s'). +Proof. + intros c e c' stk f sp rs m t s' b lb'. + intros Hexit Htc Hstep. + destruct c as [|ei c]; try (contradict Hexit; discriminate). + destruct ei; (contradict Hexit; discriminate) || ( + inversion Hexit; subst; inversion Hstep; subst; simpl + ). + * unfold inv_trans_rao in H11. + apply exec_MBcall with (f := (trans_function f0)); auto. + rewrite find_function_ptr_same in H9; auto. + apply find_funct_ptr_same. auto. + * apply exec_MBtailcall with (f := (trans_function f0)); auto. + rewrite find_function_ptr_same in H9; auto. + apply find_funct_ptr_same; auto. + rewrite parent_sp_preserved in H11; subst; auto. + rewrite parent_ra_preserved in H12; subst; auto. + * eapply exec_MBbuiltin; eauto. + eapply eval_builtin_args_preserved; eauto. + eapply external_call_symbols_preserved; eauto. + * eapply exec_MBgoto; eauto. + apply find_funct_ptr_same; eauto. + apply find_label_preserved; auto. + * eapply exec_MBcond_true; eauto. + erewrite find_funct_ptr_same; eauto. + apply find_label_preserved; auto. + * eapply exec_MBcond_false; eauto. + * eapply exec_MBjumptable; eauto. + erewrite find_funct_ptr_same; eauto. + apply find_label_preserved; auto. + * eapply exec_MBreturn; eauto. + apply find_funct_ptr_same; eauto. + rewrite parent_sp_preserved in H8; subst; auto. + rewrite parent_ra_preserved in H9; subst; auto. + rewrite mem_free_preserved in H10; subst; auto. +Qed. + +Lemma simu_end_block: + forall s1 t s1', + starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> + step rao tge (trans_state s1) t (trans_state s1'). +Proof. + destruct s1; simpl. + + (* State *) + (* c cannot be nil *) + destruct c as [|i c]; simpl; try ( (* nil => absurd *) + unfold dist_end_block_code; simpl; + intros t s1' H; inversion_clear H; + inversion_clear H0; fail + ). + + intros t s1' H. + remember (_::_) as c0. remember (trans_code c0) as tc0. + + (* tc0 cannot be nil *) + destruct tc0; try + ( exploit (trans_code_nonil c0); subst; auto; try discriminate; intro H0; contradict H0 ). + + assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))). + { + unfold dist_end_block_code. remember (size _) as siz. + assert (siz <> 0%nat). rewrite Heqsiz; apply to_bblock_nonil with (c0 := c) (i := i) (c := c0); auto. + omega. + } + + (* decomposition of starN in 3 parts: header + body + exit *) + rewrite X in H; unfold size in H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1 [H0 [H3 H4]]]]]. + subst t; clear X H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s0 [H [H1 H2]]]]]. + subst t3; clear H0. + + (* Making the hypothesis more readable *) + remember (Smallstep.step _) as Machstep. remember (globalenv _) as mge. + remember (Mach.State _ _ _ _ _ _) as si. + + unfold to_bblock in * |- *. + (* naming parts of block "b" *) + remember (to_bblock_header c0) as hd. destruct hd as [hb c1]. + remember (to_bblock_body c1) as bb. destruct bb as [bb c2]. + remember (to_bblock_exit c2) as exb. destruct exb as [exb c3]. + simpl in * |- *. + + exploit trans_code_step; eauto. intro EQ. destruct EQ as (EQH & EQB & EQE & EQTB0). + subst hb bb exb. + + (* header opt step *) + assert (X: s0 = (Mach.State stack f sp c1 rs m) /\ t1 = E0). + { + destruct (header b) eqn:EQHB. + - inversion_clear H. inversion H2. subst. + destruct i; try (contradict EQHB; inversion Heqhd; fail). + inversion H0. subst. inversion Heqhd. auto. + - simpl in H. inversion H. subst. + destruct i; try (inversion Heqhd; auto; fail). + } + clear H; destruct X as [X1 X2]; subst s0 t1. + autorewrite with trace_rewrite. + + (* body steps *) + subst mge Machstep. + exploit (star_step_simu_body_step); eauto. + clear H1; intros [rs' [m' [H0 [H1 H2]]]]. + subst s1 t2. autorewrite with trace_rewrite. + (* preparing exit step *) + eapply exec_bblock; eauto. + clear H2. + + (* exit step *) + destruct (exit b) as [e|] eqn:EQEB. + - constructor. + simpl in H3. inversion H3. subst. clear H3. + inversion H1. subst. clear H1. + destruct c2 as [|ei c2']; try (contradict Heqexb; discriminate). + rewrite E0_right. + destruct ei; try (contradict Heqexb; discriminate). + all: eapply step_simu_cfi_step; eauto. + - simpl in H3. inversion H3; subst. simpl. + destruct c2 as [|ei c2']; inversion Heqexb; subst; try eapply exec_None_exit. + clear H3. destruct (to_cfi ei) as [cfi|] eqn:TOCFI; inversion H0. + subst. eapply exec_None_exit. + + + (* Callstate *) + intros t s1' H; inversion_clear H. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + - (* function_internal*) + cutrewrite (trans_code (Mach.fn_code f0) = fn_code (trans_function f0)); eauto. + eapply exec_function_internal; eauto. + apply find_funct_ptr_same; auto. + rewrite <- parent_sp_preserved; eauto. + rewrite <- parent_ra_preserved; eauto. + - (* function_external *) + autorewrite with trace_rewrite. + eapply exec_function_external; eauto. + apply find_funct_ptr_same_external; auto. + rewrite <- parent_sp_preserved; eauto. + apply external_call_preserved; auto. + + (* Returnstate *) + intros t s1' H; inversion_clear H. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + eapply exec_return. +Qed. + +Theorem simulation: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). +Proof. + apply forward_simulation_block with (dist_end_block := dist_end_block) (build_block := trans_state). +(* simu_mid_block *) + - intros s1 t s1' H1. + destruct H1; simpl; omega || (intuition auto). +(* public_preserved *) + - apply senv_preserved. +(* match_initial_states *) + - intros. simpl. destruct H. split. + apply init_mem_preserved; auto. + rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. +(* match_final_states *) + - intros. simpl. destruct H. split with (r := r); auto. +(* final_states_end_block *) + - intros. simpl in H0. inversion H0. + inversion H; simpl; auto. + (* the remaining instructions cannot lead to a Returnstate *) + all: subst; discriminate. +(* simu_end_block *) + - apply simu_end_block. +Qed. + +End PRESERVATION. -- cgit From 7dca5905e7921b72634c31ae8de1bd08b3ff2e2e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Jun 2018 14:09:33 +0200 Subject: Machblock: some cleaning --- mppa_k1c/Machblock.v | 11 +- mppa_k1c/Machblockgen.v | 281 +++++++++++++++++-------------------------- mppa_k1c/Machblockgenproof.v | 50 ++++---- 3 files changed, 146 insertions(+), 196 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v index 9b36fc43..6d28844b 100644 --- a/mppa_k1c/Machblock.v +++ b/mppa_k1c/Machblock.v @@ -55,7 +55,7 @@ Proof. Qed. Definition length_opt {A} (o: option A) : nat := - match o with + match o with | Some o => 1 | None => 0 end. @@ -110,10 +110,11 @@ Qed. Local Open Scope nat_scope. +(* FIXME - avoir une définition un peu plus simple, au prix de la preuve Mach -> Machblock ? *) Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := match c with | nil => None - | bb1 :: bbl => if is_label lbl bb1 + | bb1 :: bbl => if is_label lbl bb1 then let bb' := {| header := None ; body := body bb1 ; exit := exit bb1 |} in ( Some (match size bb' with | O => bbl @@ -191,7 +192,7 @@ Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m: | exec_MBsetstack: forall src ofs ty m' rs', store_stack m sp ty ofs (rs src) = Some m' -> - rs' = undef_regs (destroyed_by_setstack ty) rs -> + rs' = undef_regs (destroyed_by_setstack ty) rs -> basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' | exec_MBgetparam: forall ofs ty dst v rs' f, @@ -225,8 +226,8 @@ Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> re forall rs m, body_step s f sp nil rs m rs m | exec_cons_body: - forall rs m bi p rs' m' rs'' m'', - basic_step s f sp rs m bi rs' m' -> + forall rs m bi p rs' m' rs'' m'', + basic_step s f sp rs m bi rs' m' -> body_step s f sp p rs' m' rs'' m'' -> body_step s f sp (bi::p) rs m rs'' m'' . diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 93284b0b..039e6c6e 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -26,14 +26,13 @@ Definition to_basic_inst(i: Mach.instruction): option basic_inst := | _ => None end. -(* version pas récursive terminale, mais plus facile pour la preuve *) Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code := match c with | nil => (nil,nil) - | i::c' => + | i::c' => match to_basic_inst i with - | Some bi => - let (p,c'') := to_bblock_body c' in + | Some bi => + let (p,c'') := to_bblock_body c' in (bi::p, c'') | None => (nil, c) end @@ -61,7 +60,7 @@ Definition to_cfi (i: Mach.instruction): option control_flow_inst := Definition to_bblock_exit (c: Mach.code): option control_flow_inst * Mach.code := match c with | nil => (None,nil) - | i::c' => + | i::c' => match to_cfi i with | Some bi as o => (o, c') | None => (None, c) @@ -80,195 +79,162 @@ Definition get_code_nature (c: Mach.code): code_nature := end end. -Ltac Discriminate := - match goal with - | [ H: ?a <> ?a |- _ ] => contradict H; auto - | _ => discriminate - end. - - Lemma cn_eqdec (cn1 cn2: code_nature): { cn1=cn2 } + {cn1 <> cn2}. Proof. decide equality. -Qed. +Qed. Lemma get_code_nature_nil c: c<>nil -> get_code_nature c <> IsEmpty. Proof. - intro. unfold get_code_nature. destruct c; try Discriminate. + intros H. unfold get_code_nature. + destruct c; try (contradict H; auto; fail). destruct i; discriminate. Qed. Lemma get_code_nature_nil_contra c: get_code_nature c = IsEmpty -> c = nil. Proof. - intro. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. - intro. contradict H0. + intros H. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. + intro F. contradict F. Qed. -Lemma get_code_nature_basic_inst: - forall c a c0, +Lemma get_code_nature_basic_inst c a c0: c = a :: c0 -> get_code_nature c = IsBasicInst -> to_basic_inst a <> None. Proof. - intros. destruct a; discriminate || contradict H0; subst; simpl; discriminate. + intros H1 H2. destruct a; discriminate || contradict H2; subst; simpl; discriminate. Qed. -Lemma to_bblock_header_not_IsLabel: - forall c b c0, +Lemma to_bblock_header_not_IsLabel c b c0: get_code_nature c <> IsLabel -> to_bblock_header c = (b, c0) -> c = c0 /\ b=None. Proof. - intros. destruct c. - - simpl in H0; inversion H0; auto. - - destruct i; unfold to_bblock_header in H0; inversion H0; auto. - simpl in H; contradict H; auto. + intros H1 H2. destruct c. + - simpl in H2; inversion H2; auto. + - destruct i; unfold to_bblock_header in H2; inversion H2; auto. + simpl in H1; contradict H1; auto. Qed. - -Lemma to_bblock_header_eq: - forall c b c0, +Lemma to_bblock_header_eq c b c0: get_code_nature c <> IsLabel -> to_bblock_header c = (b, c0) -> c = c0. Proof. - intros; exploit to_bblock_header_not_IsLabel; intuition eauto. + intros H1 H2; exploit to_bblock_header_not_IsLabel; intuition eauto. Qed. -Lemma to_bblock_header_IsLabel: - forall c c0 b, - get_code_nature c = IsLabel -> +Lemma to_bblock_header_IsLabel c c0 b: + get_code_nature c = IsLabel -> to_bblock_header c = (b, c0) -> exists l, c = (Mlabel l)::c0. Proof. - intros. destruct c; try discriminate. + intros H1 H2. destruct c; try discriminate. destruct i; try discriminate. - unfold to_bblock_header in H0; inversion H0; eauto. + unfold to_bblock_header in H2; inversion H2; eauto. Qed. -Lemma to_bblock_header_wf: - forall c b c0, - get_code_nature c = IsLabel -> +Lemma to_bblock_header_wf c b c0: + get_code_nature c = IsLabel -> to_bblock_header c = (b, c0) -> (length c > length c0)%nat. Proof. - intros; exploit to_bblock_header_IsLabel; eauto. - intros [l H1]; subst; simpl; auto. + intros H1 H2; exploit to_bblock_header_IsLabel; eauto. + intros [l X]; subst; simpl; auto. Qed. -Ltac ExploitHeaderEq := - match goal with - | [ H: to_bblock_header (?i0 :: ?c) = (?b, ?c0) |- _ ] => - exploit (to_bblock_header_eq (i0::c) b c0); [subst; simpl; discriminate | auto | intro; subst; auto] - | _ => idtac - end. - -Lemma to_bblock_header_wfe: - forall c b c0, +Lemma to_bblock_header_wfe c b c0: to_bblock_header c = (b, c0) -> (length c >= length c0)%nat. Proof. - intros c b c0; destruct (cn_eqdec (get_code_nature c) IsLabel). + destruct (cn_eqdec (get_code_nature c) IsLabel). - intros; exploit to_bblock_header_wf; eauto; omega. - intros; exploit to_bblock_header_eq; eauto. intros; subst; auto. Qed. -Lemma to_bblock_body_eq: - forall c b c0, +Lemma to_bblock_body_eq c b c0: get_code_nature c <> IsBasicInst -> to_bblock_body c = (b, c0) -> c = c0. Proof. - intros. destruct c. - - simpl in H0. inversion H0. auto. - - destruct i; simpl in *; try Discriminate || inversion H0; subst; auto. + intros H1 H2. destruct c. + - simpl in H2. inversion H2. auto. + - destruct i; try ( simpl in *; destruct H1; auto; fail ). + all: simpl in *; inversion H2; subst; clear H2; auto. Qed. -Lemma to_bblock_body_wfe: - forall c b c0, +Lemma to_bblock_body_wfe c b c0: to_bblock_body c = (b, c0) -> (length c >= length c0)%nat. Proof. - induction c. - - intros. simpl in H. inversion H. subst. auto. - - intros. simpl in H. destruct (to_basic_inst a). - + remember (to_bblock_body c) as tbbc. destruct tbbc as [p c'']. - exploit (IHc p c''); auto. inversion H. subst. simpl. omega. + generalize b c0; clear b c0. + induction c as [|i c]. + - intros b c0 H. simpl in H. inversion H; subst; auto. + - intros b c0 H. simpl in H. destruct (to_basic_inst i). + + remember (to_bblock_body c) as tbbc; destruct tbbc as [p c'']. + exploit (IHc p c''); auto. inversion H; subst; simpl; omega. + inversion H; subst; auto. Qed. - Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := - Cons_to_bbloc_body i bi c' b': + Cons_to_bbloc_body i bi c' b': to_basic_inst i = Some bi -> to_bblock_body c' = (b', c0) -> cons_to_bblock_body c0 (i::c') (bi::b'). -Lemma to_bblock_body_IsBasicInst: - forall c b c0, +Lemma to_bblock_body_IsBasicInst c b c0: get_code_nature c = IsBasicInst -> - to_bblock_body c = (b, c0) -> + to_bblock_body c = (b, c0) -> cons_to_bblock_body c0 c b. Proof. - intros. destruct c; [ contradict H; simpl; discriminate | ]. + intros H1 H2. destruct c; [ contradict H1; simpl; discriminate | ]. remember (to_basic_inst i) as tbii. destruct tbii. - - simpl in H0. rewrite <- Heqtbii in H0. + - simpl in H2. rewrite <- Heqtbii in H2. remember (to_bblock_body c) as tbbc. destruct tbbc as [p1 c1]. - inversion H0. subst. eapply Cons_to_bbloc_body; eauto. + inversion H2. subst. eapply Cons_to_bbloc_body; eauto. - destruct i; try discriminate. Qed. -Lemma to_bblock_body_wf: - forall c b c0, +Lemma to_bblock_body_wf c b c0: get_code_nature c = IsBasicInst -> - to_bblock_body c = (b, c0) -> + to_bblock_body c = (b, c0) -> (length c > length c0)%nat. Proof. - intros; exploit to_bblock_body_IsBasicInst; eauto. - intros H1; destruct H1. + intros H1 H2; exploit to_bblock_body_IsBasicInst; eauto. + intros X; destruct X. exploit to_bblock_body_wfe; eauto. simpl; omega. Qed. -Lemma to_bblock_exit_eq: - forall c b c0, +Lemma to_bblock_exit_eq c b c0: get_code_nature c <> IsCFI -> to_bblock_exit c = (b, c0) -> c = c0. Proof. - intros. destruct c. - - simpl in H0; inversion H0; auto. - - destruct i; unfold to_bblock_header in H0; inversion H0; auto; - simpl in H; contradict H; auto. + intros H1 H2. destruct c as [|i c]. + - simpl in H2; inversion H2; auto. + - destruct i; unfold to_bblock_header in H2; inversion H2; auto; + simpl in H1; contradict H1; auto. Qed. -Lemma to_bblock_exit_wf: - forall c b c0, +Lemma to_bblock_exit_wf c b c0: get_code_nature c = IsCFI -> to_bblock_exit c = (b, c0) -> (length c > length c0)%nat. Proof. - intros. destruct c; try discriminate. + intros H1 H2. destruct c as [|i c]; try discriminate. destruct i; try discriminate; - unfold to_bblock_header in H0; inversion H0; auto. + unfold to_bblock_header in H2; inversion H2; auto. Qed. -Ltac ExploitExitEq := - match goal with - | [ H: to_bblock_exit (?i0 :: ?c) = (?b, ?c0) |- _ ] => - exploit (to_bblock_exit_eq (i0::c) b c0); [subst; simpl; discriminate | auto | intro; subst; auto] - | _ => idtac - end. - -Lemma to_bblock_exit_wfe: - forall c b c0, +Lemma to_bblock_exit_wfe c b c0: to_bblock_exit c = (b, c0) -> (length c >= length c0)%nat. Proof. - intros. destruct c. unfold to_bblock_exit in H; inversion H; auto. - remember i as i0. - destruct i; try ExploitExitEq. - all: exploit (to_bblock_exit_wf (i0::c) b c0); [subst; simpl; auto | auto | try omega]. + intros H. destruct c as [|i c]. + - simpl in H. inversion H; subst; clear H; auto. + - destruct i; try ( simpl in H; inversion H; subst; clear H; auto ). + all: simpl; auto. Qed. Definition to_bblock(c: Mach.code): bblock * Mach.code := @@ -278,45 +244,41 @@ Definition to_bblock(c: Mach.code): bblock * Mach.code := ({| header := h; body := bdy; exit := ext |}, c2) . -Lemma to_bblock_double_label: - forall c l, +Lemma to_bblock_double_label c l: get_code_nature c = IsLabel -> to_bblock (Mlabel l :: c) = ({| header := Some l; body := nil; exit := None |}, c). Proof. - intros. - destruct c; try (contradict H; simpl; discriminate). + intros H. + destruct c as [|i c]; try (contradict H; simpl; discriminate). destruct i; try (contradict H; simpl; discriminate). - simpl. auto. + auto. Qed. -Lemma to_bblock_basic_inst_then_label: - forall i c bi, +Lemma to_bblock_basic_inst_then_label i c bi: get_code_nature (i::c) = IsBasicInst -> get_code_nature c = IsLabel -> to_basic_inst i = Some bi -> fst (to_bblock (i::c)) = {| header := None; body := bi::nil; exit := None |}. Proof. - intros. - destruct c; try (contradict H; simpl; discriminate). - destruct i0; try (contradict H; simpl; discriminate). - destruct i; simpl in *; inversion H1; subst; auto. + intros H1 H2 H3. + destruct c as [|i' c]; try (contradict H1; simpl; discriminate). + destruct i'; try (contradict H1; simpl; discriminate). + destruct i; simpl in *; inversion H3; subst; auto. Qed. -Lemma to_bblock_cf_inst_then_label: - forall i c cfi, +Lemma to_bblock_cf_inst_then_label i c cfi: get_code_nature (i::c) = IsCFI -> get_code_nature c = IsLabel -> to_cfi i = Some cfi -> fst (to_bblock (i::c)) = {| header := None; body := nil; exit := Some cfi |}. Proof. - intros. - destruct c; try (contradict H; simpl; discriminate). - destruct i0; try (contradict H; simpl; discriminate). - destruct i; simpl in *; inversion H1; subst; auto. + intros H1 H2 H3. + destruct c as [|i' c]; try (contradict H1; simpl; discriminate). + destruct i'; try (contradict H1; simpl; discriminate). + destruct i; simpl in *; inversion H3; subst; auto. Qed. -Lemma to_bblock_single_label: - forall c l, +Lemma to_bblock_single_label c l: get_code_nature c <> IsLabel -> fst (to_bblock (Mlabel l :: c)) = {| header := Some l; @@ -324,8 +286,8 @@ Lemma to_bblock_single_label: exit := exit (fst (to_bblock c)) |}. Proof. - intros. - destruct c; simpl; auto. + intros H. + destruct c as [|i c]; simpl; auto. apply bblock_eq; simpl. (* header *) + destruct i; try ( @@ -361,8 +323,7 @@ Proof. ). contradict H; simpl; auto. Qed. -Lemma to_bblock_no_label: - forall c, +Lemma to_bblock_no_label c: get_code_nature c <> IsLabel -> fst (to_bblock c) = {| header := None; @@ -370,8 +331,8 @@ Lemma to_bblock_no_label: exit := exit (fst (to_bblock c)) |}. Proof. - intros. - destruct c; simpl; auto. + intros H. + destruct c as [|i c]; simpl; auto. apply bblock_eq; simpl; destruct i; ( try ( @@ -391,7 +352,7 @@ Lemma to_bblock_body_nil c c': c = c'. Proof. intros H. - destruct c; [ simpl in *; inversion H; auto |]. + destruct c as [|i c]; [ simpl in *; inversion H; auto |]. destruct i; try ( simpl in *; remember (to_bblock_body c) as tbc; destruct tbc as [p c'']; inversion H ). all: auto. Qed. @@ -401,7 +362,7 @@ Lemma to_bblock_exit_nil c c': c = c'. Proof. intros H. - destruct c; [ simpl in *; inversion H; auto |]. + destruct c as [|i c]; [ simpl in *; inversion H; auto |]. destruct i; try ( simpl in *; remember (to_bblock_exit c) as tbe; destruct tbe as [p c'']; inversion H ). all: auto. Qed. @@ -411,8 +372,7 @@ Lemma to_bblock_label b l c c': exists bdy c1, to_bblock_body c = (bdy, c1) /\ header b = Some l /\ body b = bdy /\ exit b = fst (to_bblock_exit c1). Proof. - intros H. - (* destruct b as [bhd bbd bex]. simpl. *) + intros H. unfold to_bblock in H; simpl in H. remember (to_bblock_body c) as tbbc; destruct tbbc as [bdy' c1']. remember (to_bblock_exit c1') as tbbe; destruct tbbe as [ext c2]. @@ -438,8 +398,7 @@ Proof. exploit to_bblock_exit_nil; eauto. Qed. -Lemma to_bblock_basic_inst: - forall c i bi, +Lemma to_bblock_basic_inst c i bi: get_code_nature (i::c) = IsBasicInst -> to_basic_inst i = Some bi -> get_code_nature c <> IsLabel -> @@ -490,8 +449,7 @@ Proof. contradict H1; simpl; auto ). Qed. -Lemma to_bblock_size_single_label: - forall c i, +Lemma to_bblock_size_single_label c i: get_code_nature (i::c) = IsLabel -> get_code_nature c <> IsLabel -> size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). @@ -506,12 +464,11 @@ Proof. Unshelve. all: auto. Qed. -Lemma to_bblock_size_label_neqz: - forall c, +Lemma to_bblock_size_label_neqz c: get_code_nature c = IsLabel -> size (fst (to_bblock c)) <> 0%nat. Proof. - intros. destruct c; try (contradict H; auto; simpl; discriminate). + intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). destruct i; try (contradict H; simpl; discriminate). destruct (get_code_nature c) eqn:gcnc. (* Case gcnc is not IsLabel *) @@ -520,12 +477,11 @@ Proof. rewrite to_bblock_double_label; auto; unfold size; simpl; auto. Qed. -Lemma to_bblock_size_basicinst_neqz: - forall c, +Lemma to_bblock_size_basicinst_neqz c: get_code_nature c = IsBasicInst -> size (fst (to_bblock c)) <> 0%nat. Proof. - intros. destruct c; try (contradict H; auto; simpl; discriminate). + intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). destruct i; try (contradict H; simpl; discriminate); ( destruct (get_code_nature c) eqn:gcnc; @@ -542,17 +498,15 @@ Proof. ). Qed. -Lemma to_bblock_size_cfi_neqz: - forall c, +Lemma to_bblock_size_cfi_neqz c: get_code_nature c = IsCFI -> size (fst (to_bblock c)) <> 0%nat. Proof. - intros. destruct c; try (contradict H; auto; simpl; discriminate). + intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). destruct i; discriminate. Qed. -Lemma to_bblock_size_single_basicinst: - forall c i, +Lemma to_bblock_size_single_basicinst c i: get_code_nature (i::c) = IsBasicInst -> get_code_nature c <> IsLabel -> size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). @@ -569,7 +523,7 @@ Proof. Qed. Lemma to_bblock_wf c b c0: - c <> nil -> + c <> nil -> to_bblock c = (b, c0) -> (length c > length c0)%nat. Proof. @@ -579,7 +533,7 @@ Proof. remember (to_bblock_header c) as p1; eauto. destruct p1 as [h c1]. intro H0. - destruct gcn. + destruct gcn. - contradict H'; auto. - exploit to_bblock_header_wf; eauto. remember (to_bblock_body c1) as p2; eauto. @@ -610,23 +564,21 @@ Proof. inversion H0. omega. Qed. -Lemma to_bblock_nonil: - forall c i c0, - c = i :: c0 -> +Lemma to_bblock_nonil c i c0: + c = i :: c0 -> size (fst (to_bblock c)) <> 0%nat. Proof. - intros. remember (get_code_nature c) as gcnc. destruct gcnc. + intros H. remember (get_code_nature c) as gcnc. destruct gcnc. - contradict Heqgcnc. subst. simpl. destruct i; discriminate. - eapply to_bblock_size_label_neqz; auto. - eapply to_bblock_size_basicinst_neqz; auto. - eapply to_bblock_size_cfi_neqz; auto. Qed. -Lemma to_bblock_islabel: - forall c l, +Lemma to_bblock_islabel c l: is_label l (fst (to_bblock (Mlabel l :: c))) = true. Proof. - intros. unfold to_bblock. + unfold to_bblock. remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. remember (to_bblock_body _) as tbc; destruct tbc as [bdy c1]. remember (to_bblock_exit _) as tbe; destruct tbe as [ext c2]. @@ -634,11 +586,10 @@ Proof. apply peq_true. Qed. -Lemma body_fst_to_bblock_label: - forall l c, +Lemma body_fst_to_bblock_label l c: body (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_body c). Proof. - intros. destruct c as [|i c']; simpl; auto. + destruct c as [|i c']; simpl; auto. destruct i; simpl; auto. all: ( remember (to_bblock_body c') as tbbc; destruct tbbc as [tc c'']; simpl; @@ -652,12 +603,11 @@ Proof. ). Qed. -Lemma exit_fst_to_bblock_label: - forall c c' l, +Lemma exit_fst_to_bblock_label c c' l: snd (to_bblock_body c) = c' -> exit (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_exit c'). Proof. - intros. destruct c as [|i c]; [simpl in *; subst; auto |]. + intros H. destruct c as [|i c]; [simpl in *; subst; auto |]. unfold to_bblock. remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. remember (to_bblock_body c0) as tbc; destruct tbc as [bdy c1]. @@ -675,7 +625,7 @@ Qed. Function trans_code (c: Mach.code) { measure length c }: code := match c with | nil => nil - | _ => + | _ => let (b, c0) := to_bblock c in b::(trans_code c0) end. @@ -683,22 +633,16 @@ Proof. intros; eapply to_bblock_wf; eauto. discriminate. Qed. -(* -Functional Scheme trans_code_ind := Induction for trans_code Sort Prop. -*) - Definition hd_code (bc: code) := (hd {| header := None; body := nil; exit := None |} bc). -Lemma trans_code_nonil: - forall c, +Lemma trans_code_nonil c: c <> nil -> trans_code c <> nil. Proof. - intros. + intros H. induction c, (trans_code c) using trans_code_ind; simpl; auto. discriminate. Qed. -Lemma trans_code_step: - forall c b lb0 hb c1 bb c2 eb c3, +Lemma trans_code_step c b lb0 hb c1 bb c2 eb c3: trans_code c = b :: lb0 -> to_bblock_header c = (hb, c1) -> to_bblock_body c1 = (bb, c2) -> @@ -719,8 +663,7 @@ Proof. auto. Qed. -Lemma trans_code_cfi: - forall i c cfi, +Lemma trans_code_cfi i c cfi: to_cfi i = Some cfi -> trans_code (i :: c) = {| header := None ; body := nil ; exit := Some cfi |} :: trans_code c. Proof. @@ -735,7 +678,7 @@ Qed. (* à finir pour passer des Mach.function au function, etc. *) Definition trans_function (f: Mach.function) : function := - {| fn_sig:=Mach.fn_sig f; + {| fn_sig:=Mach.fn_sig f; fn_code:=trans_code (Mach.fn_code f); fn_stacksize := Mach.fn_stacksize f; fn_link_ofs := Mach.fn_link_ofs f; diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 838f7977..b53af131 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -17,12 +17,11 @@ Require Import Machblock. Require Import Machblockgen. Require Import ForwardSimulationBlock. -(* FIXME: put this section somewhere else. - In "Smallstep" ? - -TODO: also move "starN_last_step" in the same section ? - -*) +(** FIXME: put this section somewhere else. + * In "Smallstep" ? + * + * also move "starN_last_step" in the same section ? + *) Section starN_lemma. (* Auxiliary Lemma on starN *) @@ -35,16 +34,16 @@ Variable L: semantics. Local Hint Resolve starN_refl starN_step Eapp_assoc. -Lemma starN_split n s t s': +Lemma starN_split n s t s': starN (step L) (globalenv L) n s t s' -> - forall m k, n=m+k -> + forall m k, n=m+k -> exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. Proof. induction 1; simpl. + intros m k H; assert (X: m=0); try omega. assert (X0: k=0); try omega. subst; repeat (eapply ex_intro); intuition eauto. - + intros m; destruct m as [| m']; simpl. + + intros m; destruct m as [| m']; simpl. - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. - intros k H2. inversion H2. exploit (IHstarN m' k); eauto. intro. @@ -104,7 +103,7 @@ Proof (Genv.senv_match TRANSF). Lemma init_mem_preserved: forall m, - Genv.init_mem prog = Some m -> + Genv.init_mem prog = Some m -> Genv.init_mem tprog = Some m. Proof (Genv.init_mem_transf TRANSF). @@ -174,7 +173,7 @@ Proof. Qed. Lemma Mach_find_label_split l i c c': - Mach.find_label l (i :: c) = Some c' -> + Mach.find_label l (i :: c) = Some c' -> (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). Proof. intros H. @@ -270,7 +269,7 @@ Proof. symmetry. destruct i; try (simpl; auto). assert (l0 <> l); [ intro; subst; contradict H1; auto |]. rewrite peq_false; auto. -Qed. +Qed. Lemma to_bblock_body_find_label c2 bdy l c1: (bdy, c2) = to_bblock_body c1 -> @@ -376,6 +375,13 @@ Ltac ExploitDistEndBlockCode := | _ => idtac end. +Ltac totologize H := + match type of H with + | ( ?id = _ ) => + let Hassert := fresh "Htoto" in ( + assert (id = id) as Hassert; auto; rewrite H in Hassert at 2; simpl in Hassert; rewrite H in Hassert) + end. + (* FIXME - refactoriser avec get_code_nature pour que ce soit plus joli *) Lemma dist_end_block_code_simu_mid_block i c: dist_end_block_code (i::c) <> 0%nat -> @@ -420,7 +426,7 @@ Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. Proof. - destruct i; simpl in * |-; + destruct i; simpl in * |-; (discriminate || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. @@ -435,14 +441,14 @@ Proof. Qed. -Lemma star_step_simu_body_step s f sp c: +Lemma star_step_simu_body_step s f sp c: forall (p:bblock_body) c' rs m t s', to_bblock_body c = (p, c') -> - starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' -> + starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' -> exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp p rs m rs' m'. Proof. - induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. - * (* nil *) + induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. + * (* nil *) inversion_clear H; simpl; intros X; inversion_clear X. eapply ex_intro; eapply ex_intro; intuition eauto. * (* cons *) @@ -510,10 +516,10 @@ Lemma simu_end_block: step rao tge (trans_state s1) t (trans_state s1'). Proof. destruct s1; simpl. - + (* State *) + + (* State *) (* c cannot be nil *) - destruct c as [|i c]; simpl; try ( (* nil => absurd *) - unfold dist_end_block_code; simpl; + destruct c as [|i c]; simpl; try ( (* nil => absurd *) + unfold dist_end_block_code; simpl; intros t s1' H; inversion_clear H; inversion_clear H0; fail ). @@ -526,7 +532,7 @@ Proof. ( exploit (trans_code_nonil c0); subst; auto; try discriminate; intro H0; contradict H0 ). assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))). - { + { unfold dist_end_block_code. remember (size _) as siz. assert (siz <> 0%nat). rewrite Heqsiz; apply to_bblock_nonil with (c0 := c) (i := i) (c := c0); auto. omega. @@ -587,7 +593,7 @@ Proof. - simpl in H3. inversion H3; subst. simpl. destruct c2 as [|ei c2']; inversion Heqexb; subst; try eapply exec_None_exit. clear H3. destruct (to_cfi ei) as [cfi|] eqn:TOCFI; inversion H0. - subst. eapply exec_None_exit. + subst. eapply exec_None_exit. + (* Callstate *) intros t s1' H; inversion_clear H. -- cgit From 2e93b668df554edbfec0c23de7b14caf95a48b1d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 28 Jun 2018 10:38:26 +0200 Subject: Machblock: adaptation to the generalized ForwardSimulationBlock --- mppa_k1c/Machblock.v | 44 ++--- mppa_k1c/Machblockgen.v | 176 +++++++----------- mppa_k1c/Machblockgenproof.v | 416 +++++++++++++++++++++---------------------- 3 files changed, 292 insertions(+), 344 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v index 6d28844b..44cec642 100644 --- a/mppa_k1c/Machblock.v +++ b/mppa_k1c/Machblock.v @@ -38,7 +38,7 @@ Inductive control_flow_inst: Type := . Record bblock := mk_bblock { - header: option label; + header: list label; body: bblock_body; exit: option control_flow_inst }. @@ -60,15 +60,15 @@ Definition length_opt {A} (o: option A) : nat := | None => 0 end. -Definition size (b:bblock): nat := (length_opt (header b))+(length (body b))+(length_opt (exit b)). +Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). Lemma size_null b: size b = 0%nat -> - header b = None /\ body b = nil /\ exit b = None. + header b = nil /\ body b = nil /\ exit b = None. Proof. destruct b as [h b e]. simpl. unfold size. simpl. intros H. - assert (length_opt h = 0%nat) as Hh; [ omega |]. + assert (length h = 0%nat) as Hh; [ omega |]. assert (length b = 0%nat) as Hb; [ omega |]. assert (length_opt e = 0%nat) as He; [ omega|]. repeat split. @@ -94,34 +94,34 @@ Definition genv := Genv.t fundef unit. (*** sémantique ***) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + Definition is_label (lbl: label) (bb: bblock) : bool := - match header bb with - | Some lbl' => if peq lbl lbl' then true else false - | _ => false - end. + if in_dec lbl (header bb) then true else false. -Lemma is_label_correct: - forall lbl bb, - if is_label lbl bb then (header bb) = Some lbl else (header bb) <> Some lbl. +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. Proof. - intros. unfold is_label. destruct (header bb) as [lbl'|]; simpl; try discriminate. - case (peq lbl lbl'); intro; congruence. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. Qed. +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + Local Open Scope nat_scope. -(* FIXME - avoir une définition un peu plus simple, au prix de la preuve Mach -> Machblock ? *) Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := match c with | nil => None - | bb1 :: bbl => if is_label lbl bb1 - then let bb' := {| header := None ; body := body bb1 ; exit := exit bb1 |} in ( - Some (match size bb' with - | O => bbl - | Datatypes.S _ => bb' :: bbl - end) - ) - else find_label lbl bbl + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl end. Section RELSEM. diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 039e6c6e..0601f5b9 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -15,6 +15,15 @@ Require Import Mach. Require Import Linking. Require Import Machblock. + +Fixpoint to_bblock_header (c: Mach.code): list label * Mach.code := + match c with + | (Mlabel l)::c' => + let (h, c'') := to_bblock_header c' in + (l::h, c'') + | _ => (nil, c) + end. + Definition to_basic_inst(i: Mach.instruction): option basic_inst := match i with | Mgetstack ofs ty dst => Some (MBgetstack ofs ty dst) @@ -38,12 +47,6 @@ Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code := end end. -Definition to_bblock_header (c: Mach.code): option label * Mach.code := - match c with - | (Mlabel l)::c' => (Some l, c') - | _ => (None, c) - end. - Definition to_cfi (i: Mach.instruction): option control_flow_inst := match i with @@ -105,10 +108,10 @@ Proof. intros H1 H2. destruct a; discriminate || contradict H2; subst; simpl; discriminate. Qed. -Lemma to_bblock_header_not_IsLabel c b c0: +Lemma to_bblock_header_not_IsLabel c h c0: get_code_nature c <> IsLabel -> - to_bblock_header c = (b, c0) -> - c = c0 /\ b=None. + to_bblock_header c = (h, c0) -> + c = c0 /\ h=nil. Proof. intros H1 H2. destruct c. - simpl in H2; inversion H2; auto. @@ -116,14 +119,15 @@ Proof. simpl in H1; contradict H1; auto. Qed. -Lemma to_bblock_header_eq c b c0: +Lemma to_bblock_header_eq c h c0: get_code_nature c <> IsLabel -> - to_bblock_header c = (b, c0) -> + to_bblock_header c = (h, c0) -> c = c0. Proof. intros H1 H2; exploit to_bblock_header_not_IsLabel; intuition eauto. Qed. +(* Lemma to_bblock_header_IsLabel c c0 b: get_code_nature c = IsLabel -> to_bblock_header c = (b, c0) -> @@ -133,23 +137,33 @@ Proof. destruct i; try discriminate. unfold to_bblock_header in H2; inversion H2; eauto. Qed. +*) -Lemma to_bblock_header_wf c b c0: - get_code_nature c = IsLabel -> - to_bblock_header c = (b, c0) -> - (length c > length c0)%nat. +Lemma to_bblock_header_wfe c: + forall h c0, + to_bblock_header c = (h, c0) -> + (length c >= length c0)%nat. Proof. - intros H1 H2; exploit to_bblock_header_IsLabel; eauto. - intros [l X]; subst; simpl; auto. + induction c as [ |i c]; simpl; intros h c' H. + - inversion H; subst; clear H; simpl; auto. + - destruct i; try (inversion H; subst; simpl; auto; fail). + remember (to_bblock_header c) as bhc; destruct bhc as [h0 c0]. + inversion H; subst. + lapply (IHc h0 c'); auto. Qed. -Lemma to_bblock_header_wfe c b c0: +Lemma to_bblock_header_wf c b c0: + get_code_nature c = IsLabel -> to_bblock_header c = (b, c0) -> - (length c >= length c0)%nat. + (length c > length c0)%nat. Proof. - destruct (cn_eqdec (get_code_nature c) IsLabel). - - intros; exploit to_bblock_header_wf; eauto; omega. - - intros; exploit to_bblock_header_eq; eauto. intros; subst; auto. + intros H1 H2; destruct c; [ contradict H1; simpl; discriminate | ]. + destruct i; try discriminate. + simpl in H2. + remember (to_bblock_header c) as bh; destruct bh as [h c'']. + inversion H2; subst. + exploit to_bblock_header_wfe; eauto. + simpl; omega. Qed. Lemma to_bblock_body_eq c b c0: @@ -176,6 +190,7 @@ Proof. + inversion H; subst; auto. Qed. +(* pas vraiment utile: à éliminer *) Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := Cons_to_bbloc_body i bi c' b': to_basic_inst i = Some bi @@ -244,21 +259,22 @@ Definition to_bblock(c: Mach.code): bblock * Mach.code := ({| header := h; body := bdy; exit := ext |}, c2) . -Lemma to_bblock_double_label c l: - get_code_nature c = IsLabel -> - to_bblock (Mlabel l :: c) = ({| header := Some l; body := nil; exit := None |}, c). +Lemma to_bblock_acc_label c l b c': + to_bblock c = (b, c') -> + to_bblock (Mlabel l :: c) = ({| header := l::(header b); body := (body b); exit := (exit b) |}, c'). Proof. - intros H. - destruct c as [|i c]; try (contradict H; simpl; discriminate). - destruct i; try (contradict H; simpl; discriminate). - auto. + unfold to_bblock; simpl. + remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. + remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. + remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. + intros H; inversion H; subst; clear H; simpl; auto. Qed. Lemma to_bblock_basic_inst_then_label i c bi: get_code_nature (i::c) = IsBasicInst -> get_code_nature c = IsLabel -> to_basic_inst i = Some bi -> - fst (to_bblock (i::c)) = {| header := None; body := bi::nil; exit := None |}. + fst (to_bblock (i::c)) = {| header := nil; body := bi::nil; exit := None |}. Proof. intros H1 H2 H3. destruct c as [|i' c]; try (contradict H1; simpl; discriminate). @@ -270,7 +286,7 @@ Lemma to_bblock_cf_inst_then_label i c cfi: get_code_nature (i::c) = IsCFI -> get_code_nature c = IsLabel -> to_cfi i = Some cfi -> - fst (to_bblock (i::c)) = {| header := None; body := nil; exit := Some cfi |}. + fst (to_bblock (i::c)) = {| header := nil; body := nil; exit := Some cfi |}. Proof. intros H1 H2 H3. destruct c as [|i' c]; try (contradict H1; simpl; discriminate). @@ -278,55 +294,10 @@ Proof. destruct i; simpl in *; inversion H3; subst; auto. Qed. -Lemma to_bblock_single_label c l: - get_code_nature c <> IsLabel -> - fst (to_bblock (Mlabel l :: c)) = {| - header := Some l; - body := body (fst (to_bblock c)); - exit := exit (fst (to_bblock c)) - |}. -Proof. - intros H. - destruct c as [|i c]; simpl; auto. - apply bblock_eq; simpl. -(* header *) - + destruct i; try ( - remember (to_bblock _) as bb; - unfold to_bblock in *; - remember (to_bblock_header _) as tbh; - destruct tbh; - destruct (to_bblock_body _); - destruct (to_bblock_exit _); - subst; simpl; inversion Heqtbh; auto; fail - ). -(* body *) - + remember i as i0; destruct i0; try ( - remember (to_bblock _) as bb; - unfold to_bblock in *; - remember (to_bblock_header _) as tbh; rewrite Heqi0; - remember (to_bblock_header (i :: _)) as tbh'; rewrite <- Heqi0 in *; - destruct tbh; destruct tbh'; - inversion Heqtbh; inversion Heqtbh'; subst; - destruct (to_bblock_body _); - destruct (to_bblock_exit _); auto; fail - ). contradict H; simpl; auto. -(* exit (same proof as body) *) - + remember i as i0; destruct i0; try ( - remember (to_bblock _) as bb; - unfold to_bblock in *; - remember (to_bblock_header _) as tbh; rewrite Heqi0; - remember (to_bblock_header (i :: _)) as tbh'; rewrite <- Heqi0 in *; - destruct tbh; destruct tbh'; - inversion Heqtbh; inversion Heqtbh'; subst; - destruct (to_bblock_body _); - destruct (to_bblock_exit _); auto; fail - ). contradict H; simpl; auto. -Qed. - Lemma to_bblock_no_label c: get_code_nature c <> IsLabel -> fst (to_bblock c) = {| - header := None; + header := nil; body := body (fst (to_bblock c)); exit := exit (fst (to_bblock c)) |}. @@ -369,18 +340,16 @@ Qed. Lemma to_bblock_label b l c c': to_bblock (Mlabel l :: c) = (b, c') -> - exists bdy c1, to_bblock_body c = (bdy, c1) /\ - header b = Some l /\ body b = bdy /\ exit b = fst (to_bblock_exit c1). + (header b) = l::(tail (header b)) /\ to_bblock c = ({| header:=tail (header b); body := body b; exit := exit b |}, c'). Proof. - intros H. - unfold to_bblock in H; simpl in H. - remember (to_bblock_body c) as tbbc; destruct tbbc as [bdy' c1']. - remember (to_bblock_exit c1') as tbbe; destruct tbbe as [ext c2]. - esplit; eauto. esplit; eauto. esplit; eauto. - inversion H; subst; clear H. simpl. - apply (f_equal fst) in Heqtbbe. simpl in Heqtbbe. auto. + unfold to_bblock; simpl. + remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. + remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. + remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. + intros H; inversion H; subst; clear H; simpl; auto. Qed. +(* Lemma to_bblock_label_then_nil b l c c': to_bblock (Mlabel l :: c) = (b, c') -> body b = nil -> @@ -397,13 +366,14 @@ Proof. exploit to_bblock_body_nil; eauto. intros; subst. clear Heqtbb. exploit to_bblock_exit_nil; eauto. Qed. +*) Lemma to_bblock_basic_inst c i bi: get_code_nature (i::c) = IsBasicInst -> to_basic_inst i = Some bi -> get_code_nature c <> IsLabel -> fst (to_bblock (i::c)) = {| - header := None; + header := nil; body := bi :: body (fst (to_bblock c)); exit := exit (fst (to_bblock c)) |}. @@ -451,30 +421,22 @@ Qed. Lemma to_bblock_size_single_label c i: get_code_nature (i::c) = IsLabel -> - get_code_nature c <> IsLabel -> size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). Proof. - intros. - destruct i; try (contradict H; simpl; discriminate). - destruct c; simpl; auto. - destruct i; try ( - exploit to_bblock_single_label; eauto; intro; rewrite H1; - exploit to_bblock_no_label; eauto; intro; rewrite H2; - simpl; auto; fail ). - Unshelve. all: auto. + intros H. + destruct i; try discriminate. + remember (to_bblock c) as bl. destruct bl as [b c']. + erewrite to_bblock_acc_label; eauto. + unfold size; simpl. + auto. Qed. Lemma to_bblock_size_label_neqz c: get_code_nature c = IsLabel -> size (fst (to_bblock c)) <> 0%nat. Proof. - intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). - destruct i; try (contradict H; simpl; discriminate). - destruct (get_code_nature c) eqn:gcnc. - (* Case gcnc is not IsLabel *) - all: try (rewrite to_bblock_size_single_label; auto; rewrite gcnc; discriminate). - (* Case gcnc is IsLabel *) - rewrite to_bblock_double_label; auto; unfold size; simpl; auto. + destruct c as [ |i c]; try discriminate. + intros; rewrite to_bblock_size_single_label; auto. Qed. Lemma to_bblock_size_basicinst_neqz c: @@ -516,7 +478,7 @@ Proof. (exploit to_bblock_basic_inst; eauto); [remember (to_basic_inst _) as tbi; destruct tbi; eauto |]; intro; rewrite H1; unfold size; simpl; - assert ((length_opt (header (fst (to_bblock c)))) = 0%nat); + assert ((length (header (fst (to_bblock c)))) = 0%nat); exploit to_bblock_no_label; eauto; intro; rewrite H2; simpl; auto; rewrite H2; auto ). @@ -575,6 +537,7 @@ Proof. - eapply to_bblock_size_cfi_neqz; auto. Qed. +(* Lemma to_bblock_islabel c l: is_label l (fst (to_bblock (Mlabel l :: c))) = true. Proof. @@ -621,6 +584,7 @@ Proof. inversion Heqtbc; subst. clear Heqtbh Heqtbc. unfold to_bblock_exit in Heqtbe. apply (f_equal fst) in Heqtbe; auto. Qed. +*) Function trans_code (c: Mach.code) { measure length c }: code := match c with @@ -633,8 +597,6 @@ Proof. intros; eapply to_bblock_wf; eauto. discriminate. Qed. -Definition hd_code (bc: code) := (hd {| header := None; body := nil; exit := None |} bc). - Lemma trans_code_nonil c: c <> nil -> trans_code c <> nil. Proof. @@ -665,7 +627,7 @@ Qed. Lemma trans_code_cfi i c cfi: to_cfi i = Some cfi -> - trans_code (i :: c) = {| header := None ; body := nil ; exit := Some cfi |} :: trans_code c. + trans_code (i :: c) = {| header := nil ; body := nil ; exit := Some cfi |} :: trans_code c. Proof. intros. rewrite trans_code_equation. remember (to_bblock _) as tb; destruct tb as [b c0]. destruct i; try (contradict H; discriminate). diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index b53af131..0efd4586 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -17,45 +17,6 @@ Require Import Machblock. Require Import Machblockgen. Require Import ForwardSimulationBlock. -(** FIXME: put this section somewhere else. - * In "Smallstep" ? - * - * also move "starN_last_step" in the same section ? - *) - -Section starN_lemma. -(* Auxiliary Lemma on starN *) - -Import Smallstep. -Local Open Scope nat_scope. - - -Variable L: semantics. - -Local Hint Resolve starN_refl starN_step Eapp_assoc. - -Lemma starN_split n s t s': - starN (step L) (globalenv L) n s t s' -> - forall m k, n=m+k -> - exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. -Proof. - induction 1; simpl. - + intros m k H; assert (X: m=0); try omega. - assert (X0: k=0); try omega. - subst; repeat (eapply ex_intro); intuition eauto. - + intros m; destruct m as [| m']; simpl. - - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. - - intros k H2. inversion H2. - exploit (IHstarN m' k); eauto. intro. - destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). - repeat (eapply ex_intro). - instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). - intuition eauto. subst. auto. -Qed. - -End starN_lemma. - - Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := rao (trans_function f) (trans_code c). @@ -87,12 +48,27 @@ Definition trans_state (ms: Mach.state) : state := Section PRESERVATION. +Local Open Scope nat_scope. + Variable prog: Mach.program. Variable tprog: Machblock.program. Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. + +Variable rao: function -> code -> ptrofs -> Prop. + +Definition match_states: Mach.state -> state -> Prop + := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + apply match_states_trans_state. +Qed. + +Local Hint Resolve match_states_trans_state. + Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof (Genv.find_symbol_match TRANSF). @@ -187,95 +163,91 @@ Proof. + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. Qed. -Lemma find_label_stop l b c c0: - to_bblock (Mlabel l :: c) = (b, c0) -> find_label l (b :: trans_code c0) = Some (trans_code c). -Proof. - intros H. - unfold find_label. - assert (X: b=(fst (to_bblock (Mlabel l :: c)))). - { rewrite H; simpl; auto. } - subst b; rewrite to_bblock_islabel. - remember ({| header := None; body := _ ; exit := _ |}) as b'. - remember (fst (to_bblock _)) as b. - destruct (size b') eqn:SIZE. - - destruct (size_null b') as (Hh & Hb & He); auto. - subst b'; simpl in *. clear Hh SIZE. - erewrite <- (to_bblock_label_then_nil b l c c0); eauto. - - assert (X: exists b0 lb0, trans_code c = b0::lb0 /\ c <> nil). - { induction c, (trans_code c) using trans_code_ind. - + subst. simpl in * |-. inversion SIZE. - + (repeat econstructor 1). intro; subst; try tauto. - } - destruct X as (b0 & lb0 & X0 & X1). - unfold to_bblock in * |-. - remember (to_bblock_header _) as bh; destruct bh as [h c1]. - remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. - remember (to_bblock_exit _) as be; destruct be as [ext c3]. - unfold size in SIZE; subst b b'; simpl in * |-. - injection H; clear H; intro; subst c3. - injection Heqbh; clear Heqbh; intros; subst. - cut (to_bblock_header c = (None, c)). - * intros X2; exploit trans_code_step; eauto. - simpl; rewrite X0; clear X0. - intros (Y1 & Y2 & Y3 & Y4). subst. - rewrite Y1; clear X1; destruct b0; simpl; auto. - * destruct (cn_eqdec (get_code_nature c) IsLabel) as [ Y | Y ]. - + destruct c; simpl; try discriminate. - destruct i; simpl; try discriminate. - simpl in * |-. - inversion Heqbb; subst. simpl in * |-. - inversion Heqbe; subst; simpl in * |-. - discriminate. - + destruct c; simpl; discriminate || auto. - destruct i; simpl; auto. - destruct Y. simpl; auto. -Qed. -Lemma find_label_next l i b c c': - to_bblock (i :: c) = (b, c') -> i <> Mlabel l -> find_label l (b :: trans_code c') = find_label l (trans_code c'). +Definition concat (h: list label) (c: code): code := + match c with + | nil => {| header := h; body := nil; exit := None |}::nil + | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' + end. + +Lemma to_bblock_start_label i c l b c0: + (b, c0) = to_bblock (i :: c) + -> In l (header b) + -> i <> Mlabel l + -> exists l2, i=Mlabel l2. Proof. - intros H H1. - destruct b as [hd bd ex]. - destruct (cn_eqdec (get_code_nature (i::c)) IsLabel) as [ X | X ]. - - destruct i; try discriminate. - exploit to_bblock_label; eauto. - intros (bdy & c1 & Y1 & Y2 & Y3 & Y4). - simpl in *|-. subst. clear X. - simpl. unfold is_label; simpl. - assert (l0 <> l); [ intro; subst; contradict H1; auto |]. - rewrite peq_false; auto. - - exploit to_bblock_no_label; eauto. - intro Y. apply (f_equal fst) in H as Y1. simpl in Y1. rewrite Y in Y1. clear Y. - inversion Y1; subst; clear Y1. - simpl. auto. + unfold to_bblock. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + intros H; inversion H; subst; clear H; simpl. + destruct i; try (simpl in Heqbh; inversion Heqbh; subst; clear Heqbh; simpl; intuition eauto). Qed. -Lemma to_bblock_header_split i c h c1: - to_bblock_header (i::c)=(h, c1) - -> (exists l, i=Mlabel l /\ h=Some l /\ c1=c) \/ (forall l, i<>Mlabel l /\ h=None /\ c1=(i::c)). +Lemma find_label_stop c: + forall l b c0 c', + (b, c0) = to_bblock c + -> Mach.find_label l c = Some c' + -> In l (header b) + -> exists h, In l h /\ Some (b :: trans_code c0) = Some (concat h (trans_code c')). Proof. - destruct i; simpl; intros H; inversion H; try (constructor 2; intuition auto; discriminate). - constructor 1; eapply ex_intro; intuition eauto. + induction c as [ |i c]. + - simpl; intros; discriminate. + - intros l b c0 c' H H1 H2. + exploit Mach_find_label_split; eauto; clear H1. + intros [(X1 & X2) | (X1 & X2)]. + * subst. exploit to_bblock_label; eauto. clear H. + intros (H3 & H4). constructor 1 with (x:=l::nil); simpl; intuition auto. + symmetry. + rewrite trans_code_equation. + destruct c as [ |i c]. + + unfold to_bblock in H4; simpl in H4. + injection H4. clear H4; intros H4 H H0 H1; subst. simpl. + rewrite trans_code_equation; simpl. + rewrite <- H1 in H3; clear H1. + destruct b as [h b e]; simpl in * |- *; subst; auto. + + rewrite H4; clear H4; simpl. rewrite <- H3; clear H3. + destruct b; simpl; auto. + * exploit to_bblock_start_label; eauto. + intros (l' & H'). subst. + assert (X: l' <> l). { intro Z; subst; destruct X1; auto. } + clear X1. + exploit to_bblock_label; eauto. clear H. + intros (H3 & H4). + exploit IHc; eauto. { simpl. rewrite H3 in H2; simpl in H2. destruct H2; subst; tauto. } + intros (h' & H5 & H6). + constructor 1 with (x:=l'::h'); simpl; intuition auto. + destruct b as [h b e]; simpl in * |- *; subst. + remember (tl h) as th. subst h. + remember (trans_code c') as tcc'. + rewrite trans_code_equation in Heqtcc'. + destruct c'; subst; simpl in * |- *. + + inversion H6; subst; auto. + + destruct (to_bblock (i :: c')) as [b1 c1]. simpl in * |- *. + inversion H6; subst; auto. Qed. -Lemma to_bblock_header_find_label i c1 l c h: - i <> Mlabel l - -> to_bblock_header (i :: c) = (h, c1) -> Mach.find_label l c = Mach.find_label l c1. +Lemma to_bblock_header_find_label c l: forall c1 h c', + to_bblock_header c = (h, c1) + -> Mach.find_label l c = Some c' + -> ~ In l h + -> Mach.find_label l c = Mach.find_label l c1. Proof. - intros H1 H2; exploit to_bblock_header_split; eauto. - intros [ ( l0 & X1 & X2 & X3 ) | X ]. - - subst. auto. - - destruct (X l) as (X1 & X2 & X3). subst. clear X X1. - symmetry. destruct i; try (simpl; auto). - assert (l0 <> l); [ intro; subst; contradict H1; auto |]. - rewrite peq_false; auto. + induction c as [|i c]; simpl; auto. + - intros; discriminate. + - destruct i; + try (simpl; intros c1 h c' H1 H2; inversion H1; subst; clear H1; intros; apply refl_equal). + remember (to_bblock_header c) as tbhc. destruct tbhc as [h2 c2]. + intros h c1 c' H1; inversion H1; subst; clear H1. + simpl. destruct (peq _ _). + + subst; tauto. + + intros H1 H2; erewrite IHc; eauto. Qed. -Lemma to_bblock_body_find_label c2 bdy l c1: +Lemma to_bblock_body_find_label c1 l: forall c2 bdy, (bdy, c2) = to_bblock_body c1 -> Mach.find_label l c1 = Mach.find_label l c2. Proof. - generalize bdy c2. induction c1 as [|i c1]. - intros bdy0 c0 H. simpl in H. inversion H; subst; clear H. auto. - intros bdy' c2' H. simpl in H. destruct i; try ( @@ -283,7 +255,7 @@ Proof. inversion H; subst; clear H; simpl; erewrite IHc1; eauto; fail). Qed. -Lemma to_bblock_exit_find_label c2 ext l c1: +Lemma to_bblock_exit_find_label c1 l c2 ext: (ext, c2) = to_bblock_exit c1 -> Mach.find_label l c1 = Mach.find_label l c2. Proof. @@ -293,43 +265,37 @@ Proof. simpl in H; inversion H; subst; clear H; auto; fail). Qed. -Lemma Mach_find_label_to_bblock i c l b c0: - i <> Mlabel l - -> to_bblock (i :: c) = (b, c0) - -> Mach.find_label l c = Mach.find_label l c0. -Proof. - intro H. - unfold to_bblock. - remember (to_bblock_header _) as bh; destruct bh as [h c1]. - remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. - remember (to_bblock_exit _) as be; destruct be as [ext c3]. - intros X; injection X. clear X; intros; subst. - erewrite (to_bblock_header_find_label i c1); eauto. - erewrite (to_bblock_body_find_label c2); eauto. - erewrite to_bblock_exit_find_label; eauto. -Qed. - -Local Hint Resolve find_label_next. - Lemma find_label_transcode_preserved: forall l c c', Mach.find_label l c = Some c' -> - find_label l (trans_code c) = Some (trans_code c'). + exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). Proof. intros l c; induction c, (trans_code c) using trans_code_ind. - intros c' H; inversion H. - intros c' H. subst _x. destruct c as [| i c]; try tauto. - exploit Mach_find_label_split; eauto. clear H. - intros [ [H1 H2] | [H1 H2] ]. - + subst. erewrite find_label_stop; eauto. - + rewrite <- IHc0. eauto. - erewrite <- (Mach_find_label_to_bblock i c); eauto. + unfold to_bblock in * |-. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + simpl; injection e0; intros; subst; clear e0. + unfold is_label; simpl; destruct (in_dec l h) as [Y|Y]. + + clear IHc0. + eapply find_label_stop; eauto. + unfold to_bblock. + rewrite <- Heqbh, <- Heqbb, <- Heqbe. + auto. + + exploit IHc0; eauto. clear IHc0. + rewrite <- H. + erewrite (to_bblock_header_find_label (i::c) l c1); eauto. + erewrite (to_bblock_body_find_label c1 l c2); eauto. + erewrite (to_bblock_exit_find_label c2 l c0); eauto. Qed. + Lemma find_label_preserved: forall l f c, Mach.find_label l (Mach.fn_code f) = Some c -> - find_label l (fn_code (trans_function f)) = Some (trans_code c). + exists h, In l h /\ find_label l (fn_code (trans_function f)) = Some (concat h (trans_code c)). Proof. intros. cutrewrite ((fn_code (trans_function f)) = trans_code (Mach.fn_code f)); eauto. apply find_label_transcode_preserved; auto. @@ -357,15 +323,6 @@ Definition dist_end_block (s: Mach.state): nat := Local Hint Resolve exec_nil_body exec_cons_body. Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. -Variable rao: function -> code -> ptrofs -> Prop. - -(* -Lemma minus_diff_0 n: (n-1<>0)%nat -> (n >= 2)%nat. -Proof. - omega. -Qed. -*) - Ltac ExploitDistEndBlockCode := match goal with | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => @@ -384,13 +341,13 @@ Ltac totologize H := (* FIXME - refactoriser avec get_code_nature pour que ce soit plus joli *) Lemma dist_end_block_code_simu_mid_block i c: - dist_end_block_code (i::c) <> 0%nat -> - (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c))%nat. + dist_end_block_code (i::c) <> 0 -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). Proof. - intros. + intros H. remember (get_code_nature c) as gcnc; destruct gcnc. (* when c is nil *) - - contradict H. rewrite get_code_nature_nil_contra with (c := c); auto. destruct i; simpl; auto. + - contradict H; rewrite get_code_nature_nil_contra with (c := c); auto. destruct i; simpl; auto. (* when c is IsLabel *) - remember i as i0; remember (to_basic_inst i) as sbi; remember (to_cfi i) as scfi; remember (get_code_nature (i::c)) as gcnic; @@ -408,16 +365,19 @@ Proof. | intro; subst; rewrite H; simpl; auto ] ); fail). (* when i is a label *) - contradict H. unfold dist_end_block_code. exploit to_bblock_double_label; eauto. - intro. subst. rewrite H. simpl. auto. + unfold dist_end_block_code in * |- *. subst i0. + rewrite (to_bblock_size_single_label c (Mlabel l)) in * |- *; simpl in * |- *; auto. omega. (* when c is IsBasicInst or IsCFI *) + +(* - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). -Qed. +*) +Admitted. Local Hint Resolve dist_end_block_code_simu_mid_block. @@ -468,12 +428,33 @@ Proof. intros X; inversion_clear X. intuition 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. + +Lemma match_states_concat_trans_code st f sp c rs m h: + match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). +Proof. + constructor 1; simpl. + + intros (t0 & s1' & H0) t s'. + rewrite! trans_code_equation. + destruct c as [| i c]. { inversion H0. } + remember (to_bblock (i :: c)) as bic. destruct bic as [b c0]. + simpl. + constructor 1; intros H; inversion H; subst; simpl in * |- *; + eapply exec_bblock; eauto. + - inversion H11; subst; eauto. + inversion H2; subst; eauto. + - inversion H11; subst; simpl; eauto. + inversion H2; subst; simpl; eauto. + + intros H r; constructor 1; intro X; inversion X. +Qed. + Lemma step_simu_cfi_step: forall c e c' stk f sp rs m t s' b lb', to_bblock_exit c = (Some e, c') -> trans_code c' = lb' -> Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp c rs m) t s' -> - cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t (trans_state s'). + exists s2, cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t s2 /\ match_states s' s2. Proof. intros c e c' stk f sp rs m t s' b lb'. intros Hexit Htc Hstep. @@ -482,38 +463,66 @@ Proof. inversion Hexit; subst; inversion Hstep; subst; simpl ). * unfold inv_trans_rao in H11. + eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. apply exec_MBcall with (f := (trans_function f0)); auto. rewrite find_function_ptr_same in H9; auto. - apply find_funct_ptr_same. auto. - * apply exec_MBtailcall with (f := (trans_function f0)); auto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + apply exec_MBtailcall with (f := (trans_function f0)); auto. rewrite find_function_ptr_same in H9; auto. - apply find_funct_ptr_same; auto. rewrite parent_sp_preserved in H11; subst; auto. rewrite parent_ra_preserved in H12; subst; auto. - * eapply exec_MBbuiltin; eauto. - eapply eval_builtin_args_preserved; eauto. - eapply external_call_symbols_preserved; eauto. - * eapply exec_MBgoto; eauto. - apply find_funct_ptr_same; eauto. - apply find_label_preserved; auto. - * eapply exec_MBcond_true; eauto. - erewrite find_funct_ptr_same; eauto. - apply find_label_preserved; auto. - * eapply exec_MBcond_false; eauto. - * eapply exec_MBjumptable; eauto. - erewrite find_funct_ptr_same; eauto. - apply find_label_preserved; auto. - * eapply exec_MBreturn; eauto. - apply find_funct_ptr_same; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBbuiltin; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBcond_false; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBreturn; eauto. rewrite parent_sp_preserved in H8; subst; auto. rewrite parent_ra_preserved in H9; subst; auto. - rewrite mem_free_preserved in H10; subst; auto. Qed. + + +Lemma step_simu_exit_step c e c' stk f sp rs m t s' b: + to_bblock_exit c = (e, c') -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s' -> + exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::trans_code c') rs m) t s2 /\ match_states s' s2. +Proof. + intros H1 H2; destruct e as [ e |]; inversion_clear H2. + + (* Some *) inversion H0; clear H0; subst. autorewrite with trace_rewrite. + exploit step_simu_cfi_step; eauto. + intros (s2' & H2 & H3); eapply ex_intro; intuition eauto. + + (* None *) + destruct c as [ |i c]; simpl in H1; inversion H1. + - eapply ex_intro; intuition eauto; try eapply match_states_trans_state. + - remember to_cfi as o. destruct o; try discriminate. + inversion_clear H1. + eapply ex_intro; intuition eauto; try eapply match_states_trans_state. +Qed. + +Lemma step_simu_header st f sp rs m s c: forall h c' t, + (h, c') = to_bblock_header c -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. +Proof. + induction c as [ | i c]; simpl; intros h c' t H. + - inversion_clear H. simpl; intros H; inversion H; auto. + - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). + remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0]. + injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. + inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. + exploit IHc; eauto. +Qed. + Lemma simu_end_block: forall s1 t s1', starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> - step rao tge (trans_state s1) t (trans_state s1'). + exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. Proof. destruct s1; simpl. + (* State *) @@ -545,10 +554,6 @@ Proof. destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s0 [H [H1 H2]]]]]. subst t3; clear H0. - (* Making the hypothesis more readable *) - remember (Smallstep.step _) as Machstep. remember (globalenv _) as mge. - remember (Mach.State _ _ _ _ _ _) as si. - unfold to_bblock in * |- *. (* naming parts of block "b" *) remember (to_bblock_header c0) as hd. destruct hd as [hb c1]. @@ -560,49 +565,27 @@ Proof. subst hb bb exb. (* header opt step *) - assert (X: s0 = (Mach.State stack f sp c1 rs m) /\ t1 = E0). - { - destruct (header b) eqn:EQHB. - - inversion_clear H. inversion H2. subst. - destruct i; try (contradict EQHB; inversion Heqhd; fail). - inversion H0. subst. inversion Heqhd. auto. - - simpl in H. inversion H. subst. - destruct i; try (inversion Heqhd; auto; fail). - } - clear H; destruct X as [X1 X2]; subst s0 t1. + exploit step_simu_header; eauto. + intros [X1 X2]; subst s0 t1. autorewrite with trace_rewrite. - (* body steps *) - subst mge Machstep. exploit (star_step_simu_body_step); eauto. clear H1; intros [rs' [m' [H0 [H1 H2]]]]. subst s1 t2. autorewrite with trace_rewrite. - (* preparing exit step *) - eapply exec_bblock; eauto. - clear H2. - (* exit step *) - destruct (exit b) as [e|] eqn:EQEB. - - constructor. - simpl in H3. inversion H3. subst. clear H3. - inversion H1. subst. clear H1. - destruct c2 as [|ei c2']; try (contradict Heqexb; discriminate). - rewrite E0_right. - destruct ei; try (contradict Heqexb; discriminate). - all: eapply step_simu_cfi_step; eauto. - - simpl in H3. inversion H3; subst. simpl. - destruct c2 as [|ei c2']; inversion Heqexb; subst; try eapply exec_None_exit. - clear H3. destruct (to_cfi ei) as [cfi|] eqn:TOCFI; inversion H0. - subst. eapply exec_None_exit. - + subst tc0. + exploit step_simu_exit_step; eauto. clear H3. + intros (s2' & H3 & H4). + eapply ex_intro; intuition eauto. + eapply exec_bblock; eauto. + (* Callstate *) intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. inversion H1; subst; clear H1. inversion_clear H0; simpl. - (* function_internal*) cutrewrite (trans_code (Mach.fn_code f0) = fn_code (trans_function f0)); eauto. eapply exec_function_internal; eauto. - apply find_funct_ptr_same; auto. rewrite <- parent_sp_preserved; eauto. rewrite <- parent_ra_preserved; eauto. - (* function_external *) @@ -610,9 +593,9 @@ Proof. eapply exec_function_external; eauto. apply find_funct_ptr_same_external; auto. rewrite <- parent_sp_preserved; eauto. - apply external_call_preserved; auto. + (* Returnstate *) intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. inversion H1; subst; clear H1. inversion_clear H0; simpl. eapply exec_return. @@ -620,14 +603,17 @@ Qed. Theorem simulation: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. - apply forward_simulation_block with (dist_end_block := dist_end_block) (build_block := trans_state). + apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) - intros s1 t s1' H1. destruct H1; simpl; omega || (intuition auto). (* public_preserved *) - apply senv_preserved. (* match_initial_states *) - - intros. simpl. destruct H. split. + - intros. simpl. + eapply ex_intro; constructor 1. + eapply match_states_trans_state. + destruct H. split. apply init_mem_preserved; auto. rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. (* match_final_states *) -- cgit From edb93401b3621e8e9731c0a50afdbcc441d7f495 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 12 Jul 2018 14:58:06 +0200 Subject: Machblock: some renaming and proof simplifications --- mppa_k1c/Machblockgen.v | 294 ++++++++++++++++--------------------------- mppa_k1c/Machblockgenproof.v | 71 ++++++----- 2 files changed, 144 insertions(+), 221 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 0601f5b9..aa54e8a2 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -94,51 +94,21 @@ Proof. destruct i; discriminate. Qed. -Lemma get_code_nature_nil_contra c: get_code_nature c = IsEmpty -> c = nil. +Lemma get_code_nature_empty c: get_code_nature c = IsEmpty -> c = nil. Proof. intros H. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. intro F. contradict F. Qed. -Lemma get_code_nature_basic_inst c a c0: - c = a :: c0 -> - get_code_nature c = IsBasicInst -> - to_basic_inst a <> None. -Proof. - intros H1 H2. destruct a; discriminate || contradict H2; subst; simpl; discriminate. -Qed. - -Lemma to_bblock_header_not_IsLabel c h c0: - get_code_nature c <> IsLabel -> - to_bblock_header c = (h, c0) -> - c = c0 /\ h=nil. -Proof. - intros H1 H2. destruct c. - - simpl in H2; inversion H2; auto. - - destruct i; unfold to_bblock_header in H2; inversion H2; auto. - simpl in H1; contradict H1; auto. -Qed. - -Lemma to_bblock_header_eq c h c0: +Lemma to_bblock_header_noLabel c: get_code_nature c <> IsLabel -> - to_bblock_header c = (h, c0) -> - c = c0. + to_bblock_header c = (nil, c). Proof. - intros H1 H2; exploit to_bblock_header_not_IsLabel; intuition eauto. + intros H. destruct c as [|i c]; auto. + destruct i; simpl; auto. + contradict H; simpl; auto. Qed. -(* -Lemma to_bblock_header_IsLabel c c0 b: - get_code_nature c = IsLabel -> - to_bblock_header c = (b, c0) -> - exists l, c = (Mlabel l)::c0. -Proof. - intros H1 H2. destruct c; try discriminate. - destruct i; try discriminate. - unfold to_bblock_header in H2; inversion H2; eauto. -Qed. -*) - Lemma to_bblock_header_wfe c: forall h c0, to_bblock_header c = (h, c0) -> @@ -166,15 +136,13 @@ Proof. simpl; omega. Qed. -Lemma to_bblock_body_eq c b c0: +Lemma to_bblock_body_noBasic c: get_code_nature c <> IsBasicInst -> - to_bblock_body c = (b, c0) -> - c = c0. + to_bblock_body c = (nil, c). Proof. - intros H1 H2. destruct c. - - simpl in H2. inversion H2. auto. - - destruct i; try ( simpl in *; destruct H1; auto; fail ). - all: simpl in *; inversion H2; subst; clear H2; auto. + intros H. destruct c as [|i c]; simpl; auto. + destruct i; simpl; auto. + all: contradict H; simpl; auto. Qed. Lemma to_bblock_body_wfe c b c0: @@ -190,7 +158,35 @@ Proof. + inversion H; subst; auto. Qed. -(* pas vraiment utile: à éliminer *) +(** Attempt to eliminate cons_to_bblock_body *) +(* +Lemma to_bblock_body_basic c: + get_code_nature c = IsBasicInst -> + exists i bi b c', + to_basic_inst i = Some bi + /\ c = i :: c' + /\ to_bblock_body c = (bi::b, snd (to_bblock_body c')). +Proof. + intros H. + destruct c as [|i c]; try (contradict H; simpl; discriminate). + destruct i eqn:I; try (contradict H; simpl; discriminate). + all: simpl; destruct (to_bblock_body c) as [p c''] eqn:TBBC; repeat (eapply ex_intro); (repeat split); + simpl; eauto; rewrite TBBC; simpl; eauto. +Qed. + +Lemma to_bblock_body_wf c b c0: + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros H1 H2; exploit to_bblock_body_basic; eauto. + intros X. destruct X as (i & bi & b' & c' & X1 & X2 & X3). + exploit to_bblock_body_wfe. eauto. subst. simpl. + rewrite X3 in H2. inversion H2; clear H2; subst. + simpl; omega. +Qed. +*) + Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := Cons_to_bbloc_body i bi c' b': to_basic_inst i = Some bi @@ -216,20 +212,18 @@ Lemma to_bblock_body_wf c b c0: (length c > length c0)%nat. Proof. intros H1 H2; exploit to_bblock_body_IsBasicInst; eauto. - intros X; destruct X. - exploit to_bblock_body_wfe; eauto. + intros X. destruct X. + exploit to_bblock_body_wfe; eauto. subst. simpl. simpl; omega. Qed. -Lemma to_bblock_exit_eq c b c0: +Lemma to_bblock_exit_noCFI c: get_code_nature c <> IsCFI -> - to_bblock_exit c = (b, c0) -> - c = c0. + to_bblock_exit c = (None, c). Proof. - intros H1 H2. destruct c as [|i c]. - - simpl in H2; inversion H2; auto. - - destruct i; unfold to_bblock_header in H2; inversion H2; auto; - simpl in H1; contradict H1; auto. + intros H. destruct c as [|i c]; simpl; auto. + destruct i; simpl; auto. + all: contradict H; simpl; auto. Qed. Lemma to_bblock_exit_wf c b c0: @@ -270,7 +264,7 @@ Proof. intros H; inversion H; subst; clear H; simpl; auto. Qed. -Lemma to_bblock_basic_inst_then_label i c bi: +Lemma to_bblock_basic_then_label i c bi: get_code_nature (i::c) = IsBasicInst -> get_code_nature c = IsLabel -> to_basic_inst i = Some bi -> @@ -282,19 +276,17 @@ Proof. destruct i; simpl in *; inversion H3; subst; auto. Qed. -Lemma to_bblock_cf_inst_then_label i c cfi: +Lemma to_bblock_CFI i c cfi: get_code_nature (i::c) = IsCFI -> - get_code_nature c = IsLabel -> to_cfi i = Some cfi -> fst (to_bblock (i::c)) = {| header := nil; body := nil; exit := Some cfi |}. Proof. - intros H1 H2 H3. - destruct c as [|i' c]; try (contradict H1; simpl; discriminate). - destruct i'; try (contradict H1; simpl; discriminate). - destruct i; simpl in *; inversion H3; subst; auto. + intros H1 H2. + destruct i; try discriminate. + all: subst; rewrite <- H2; simpl; auto. Qed. -Lemma to_bblock_no_label c: +Lemma to_bblock_noLabel c: get_code_nature c <> IsLabel -> fst (to_bblock c) = {| header := nil; @@ -349,26 +341,7 @@ Proof. intros H; inversion H; subst; clear H; simpl; auto. Qed. -(* -Lemma to_bblock_label_then_nil b l c c': - to_bblock (Mlabel l :: c) = (b, c') -> - body b = nil -> - exit b = None -> - c = c'. -Proof. - intros TOB BB EB. - unfold to_bblock in TOB. - remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. - remember (to_bblock_body _) as tbb; destruct tbb as [bdy c1]. - remember (to_bblock_exit _) as tbe; destruct tbe as [ext c2]. - inversion TOB; subst. simpl in *. clear TOB. - inversion Heqtbh; subst. clear Heqtbh. - exploit to_bblock_body_nil; eauto. intros; subst. clear Heqtbb. - exploit to_bblock_exit_nil; eauto. -Qed. -*) - -Lemma to_bblock_basic_inst c i bi: +Lemma to_bblock_basic c i bi: get_code_nature (i::c) = IsBasicInst -> to_basic_inst i = Some bi -> get_code_nature c <> IsLabel -> @@ -383,40 +356,41 @@ Proof. apply bblock_eq; simpl. (* header *) + destruct i; simpl; auto; ( - exploit to_bblock_no_label; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]). + exploit to_bblock_noLabel; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]). (* body *) (* FIXME - the proof takes some time to prove.. N² complexity :( *) - + destruct i; inversion H0; try ( - destruct i0; try ( - subst; unfold to_bblock; - remember (to_bblock_header _) as tbh; destruct tbh; - remember (to_bblock_header (_::c)) as tbh'; destruct tbh'; - inversion Heqtbh; inversion Heqtbh'; subst; - - remember (to_bblock_body _) as tbb; destruct tbb; - remember (to_bblock_body (_::c)) as tbb'; destruct tbb'; - inversion Heqtbb; inversion Heqtbb'; destruct (to_bblock_body c); - inversion H3; inversion H4; subst; - - remember (to_bblock_exit _) as tbc; destruct tbc; - simpl; auto ); - contradict H1; simpl; auto ). -(* exit - same as body *) - + destruct i; inversion H0; try ( - destruct i0; try ( - subst; unfold to_bblock; - remember (to_bblock_header _) as tbh; destruct tbh; - remember (to_bblock_header (_::c)) as tbh'; destruct tbh'; - inversion Heqtbh; inversion Heqtbh'; subst; - - remember (to_bblock_body _) as tbb; destruct tbb; - remember (to_bblock_body (_::c)) as tbb'; destruct tbb'; - inversion Heqtbb; inversion Heqtbb'; destruct (to_bblock_body c); - inversion H3; inversion H4; subst; - - remember (to_bblock_exit _) as tbc; destruct tbc; - simpl; auto ); - contradict H1; simpl; auto ). + + unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh. + remember (to_bblock_body _) as tbb; destruct tbb. + remember (to_bblock_exit _) as tbe; destruct tbe. + simpl. + destruct i; destruct i0. + all: try (simpl in H1; contradiction). + all: try discriminate. + all: try ( + simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; + simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; + inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; + inversion H0; clear H0; subst; destruct (to_bblock_body c); + inversion Heqtbbc; clear Heqtbbc; subst; + destruct (to_bblock_exit c1); simpl; auto; fail). +(* exit *) + + unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh. + remember (to_bblock_body _) as tbb; destruct tbb. + remember (to_bblock_exit _) as tbe; destruct tbe. + simpl. + destruct i; destruct i0. + all: try (simpl in H1; contradiction). + all: try discriminate. + all: try ( + simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; + simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; + inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; + inversion H0; clear H0; subst; destruct (to_bblock_body c) eqn:TBBC; + inversion Heqtbbc; clear Heqtbbc; subst; + destruct (to_bblock_exit c1) eqn:TBBE; simpl; + inversion Heqtbe; clear Heqtbe; subst; auto; fail). Qed. Lemma to_bblock_size_single_label c i: @@ -439,7 +413,7 @@ Proof. intros; rewrite to_bblock_size_single_label; auto. Qed. -Lemma to_bblock_size_basicinst_neqz c: +Lemma to_bblock_size_basic_neqz c: get_code_nature c = IsBasicInst -> size (fst (to_bblock c)) <> 0%nat. Proof. @@ -448,12 +422,12 @@ Proof. ( destruct (get_code_nature c) eqn:gcnc; (* Case gcnc is not IsLabel *) - try (erewrite to_bblock_basic_inst; eauto; [ + try (erewrite to_bblock_basic; eauto; [ unfold size; simpl; auto | simpl; auto | rewrite gcnc; discriminate ]); - erewrite to_bblock_basic_inst_then_label; eauto; [ + erewrite to_bblock_basic_then_label; eauto; [ unfold size; simpl; auto | simpl; auto ] @@ -468,18 +442,18 @@ Proof. destruct i; discriminate. Qed. -Lemma to_bblock_size_single_basicinst c i: +Lemma to_bblock_size_single_basic c i: get_code_nature (i::c) = IsBasicInst -> get_code_nature c <> IsLabel -> size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). Proof. intros. destruct i; try (contradict H; simpl; discriminate); try ( - (exploit to_bblock_basic_inst; eauto); + (exploit to_bblock_basic; eauto); [remember (to_basic_inst _) as tbi; destruct tbi; eauto |]; intro; rewrite H1; unfold size; simpl; assert ((length (header (fst (to_bblock c)))) = 0%nat); - exploit to_bblock_no_label; eauto; intro; rewrite H2; simpl; auto; + exploit to_bblock_noLabel; eauto; intro; rewrite H2; simpl; auto; rewrite H2; auto ). Qed. @@ -505,87 +479,37 @@ Proof. destruct p3 as [h3 c3]. exploit to_bblock_exit_wfe; eauto. inversion H0. omega. - - exploit to_bblock_header_eq; eauto. rewrite <- Heqgcn. discriminate. - intro; subst. - remember (to_bblock_body c1) as p2; eauto. + - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. + intro. rewrite H1 in Heqp1. inversion Heqp1. clear Heqp1. subst. + remember (to_bblock_body c) as p2; eauto. destruct p2 as [h2 c2]. exploit to_bblock_body_wf; eauto. remember (to_bblock_exit c2) as p3; eauto. destruct p3 as [h3 c3]. exploit to_bblock_exit_wfe; eauto. inversion H0. omega. - - exploit to_bblock_header_eq; eauto. rewrite <- Heqgcn. discriminate. - intro; subst. - remember (to_bblock_body c1) as p2; eauto. + - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. + intro. rewrite H1 in Heqp1. inversion Heqp1; clear Heqp1; subst. + remember (to_bblock_body c) as p2; eauto. destruct p2 as [h2 c2]. - exploit (to_bblock_body_eq c1 h2 c2); eauto. rewrite <- Heqgcn. discriminate. - intro; subst. - remember (to_bblock_exit c2) as p3; eauto. + exploit (to_bblock_body_noBasic c); eauto. rewrite <- Heqgcn. discriminate. + intros H2; rewrite H2 in Heqp2; inversion Heqp2; clear Heqp2; subst. + remember (to_bblock_exit c) as p3; eauto. destruct p3 as [h3 c3]. - exploit (to_bblock_exit_wf c2 h3 c3); eauto. + exploit (to_bblock_exit_wf c h3 c3); eauto. inversion H0. omega. Qed. -Lemma to_bblock_nonil c i c0: - c = i :: c0 -> - size (fst (to_bblock c)) <> 0%nat. +Lemma to_bblock_nonil i c0: + size (fst (to_bblock (i :: c0))) <> 0%nat. Proof. - intros H. remember (get_code_nature c) as gcnc. destruct gcnc. + intros H. remember (i::c0) as c. remember (get_code_nature c) as gcnc. destruct gcnc. - contradict Heqgcnc. subst. simpl. destruct i; discriminate. - - eapply to_bblock_size_label_neqz; auto. - - eapply to_bblock_size_basicinst_neqz; auto. - - eapply to_bblock_size_cfi_neqz; auto. + - eapply to_bblock_size_label_neqz; eauto. + - eapply to_bblock_size_basic_neqz; eauto. + - eapply to_bblock_size_cfi_neqz; eauto. Qed. -(* -Lemma to_bblock_islabel c l: - is_label l (fst (to_bblock (Mlabel l :: c))) = true. -Proof. - unfold to_bblock. - remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. - remember (to_bblock_body _) as tbc; destruct tbc as [bdy c1]. - remember (to_bblock_exit _) as tbe; destruct tbe as [ext c2]. - simpl. inversion Heqtbh. unfold is_label. simpl. - apply peq_true. -Qed. - -Lemma body_fst_to_bblock_label l c: - body (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_body c). -Proof. - destruct c as [|i c']; simpl; auto. - destruct i; simpl; auto. - all: ( - remember (to_bblock_body c') as tbbc; destruct tbbc as [tc c'']; simpl; - unfold to_bblock; - remember (to_bblock_header _) as tbh; destruct tbh as [h c0]; - remember (to_bblock_body c0) as tbc; destruct tbc as [bdy c1]; - remember (to_bblock_exit c1) as tbe; destruct tbe as [ext c2]; - simpl; simpl in Heqtbh; inversion Heqtbh; subst c0; - simpl in Heqtbc; remember (to_bblock_body c') as tbc'; destruct tbc' as [tc' osef]; - inversion Heqtbc; inversion Heqtbbc; auto - ). -Qed. - -Lemma exit_fst_to_bblock_label c c' l: - snd (to_bblock_body c) = c' -> - exit (fst (to_bblock (Mlabel l :: c))) = fst (to_bblock_exit c'). -Proof. - intros H. destruct c as [|i c]; [simpl in *; subst; auto |]. - unfold to_bblock. - remember (to_bblock_header _) as tbh; destruct tbh as [h c0]. - remember (to_bblock_body c0) as tbc; destruct tbc as [bdy c1]. - remember (to_bblock_exit c1) as tbe; destruct tbe as [ext c2]. - simpl in *. inversion Heqtbh; subst. - destruct (to_basic_inst i) eqn:TBI. - - remember (to_bblock_body c) as tbbc; destruct tbbc as [p c'']. - simpl. simpl in Heqtbc. rewrite TBI in Heqtbc. rewrite <- Heqtbbc in Heqtbc. - inversion Heqtbc; subst. apply (f_equal fst) in Heqtbe; auto. - - simpl. simpl in Heqtbc. rewrite TBI in Heqtbc. - inversion Heqtbc; subst. clear Heqtbh Heqtbc. unfold to_bblock_exit in Heqtbe. - apply (f_equal fst) in Heqtbe; auto. -Qed. -*) - Function trans_code (c: Mach.code) { measure length c }: code := match c with | nil => nil diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 0efd4586..62391792 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -328,7 +328,7 @@ Ltac ExploitDistEndBlockCode := | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => exploit (to_bblock_size_single_label c (Mlabel l)); eauto | [ H : dist_end_block_code (?i0 :: ?c) <> 0%nat |- _ ] => - exploit (to_bblock_size_single_basicinst c i0); eauto + exploit (to_bblock_size_single_basic c i0); eauto | _ => idtac end. @@ -339,45 +339,44 @@ Ltac totologize H := assert (id = id) as Hassert; auto; rewrite H in Hassert at 2; simpl in Hassert; rewrite H in Hassert) end. -(* FIXME - refactoriser avec get_code_nature pour que ce soit plus joli *) Lemma dist_end_block_code_simu_mid_block i c: dist_end_block_code (i::c) <> 0 -> (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). Proof. intros H. - remember (get_code_nature c) as gcnc; destruct gcnc. - (* when c is nil *) - - contradict H; rewrite get_code_nature_nil_contra with (c := c); auto. destruct i; simpl; auto. - (* when c is IsLabel *) - - remember i as i0; remember (to_basic_inst i) as sbi; remember (to_cfi i) as scfi; - remember (get_code_nature (i::c)) as gcnic; - destruct i. - (* when i is a basic instruction *) - 1-6: try (( contradict H; unfold dist_end_block_code; exploit to_bblock_basic_inst_then_label; eauto; - [ totologize Heqgcnic; eapply Htoto - | totologize Heqsbi; try eapply Htoto - | intro; subst; rewrite H; simpl; auto - ] ); fail). - (* when i is a control flow instruction *) - 1-8: try (( contradict H; unfold dist_end_block_code; exploit to_bblock_cf_inst_then_label; eauto; - [ totologize Heqgcnic; eapply Htoto - | totologize Heqscfi; try eapply Htoto - | intro; subst; rewrite H; simpl; auto - ] ); fail). - (* when i is a label *) - unfold dist_end_block_code in * |- *. subst i0. - rewrite (to_bblock_size_single_label c (Mlabel l)) in * |- *; simpl in * |- *; auto. omega. - (* when c is IsBasicInst or IsCFI *) - -(* - - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) - ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | - unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). - - destruct i; try (contradict H; auto; fail); (* getting rid of the non basic inst *) - ( ExploitDistEndBlockCode; [ rewrite <- Heqgcnc; discriminate | - unfold dist_end_block_code in *; intro; rewrite H0 in *; omega ] ). -*) -Admitted. + unfold dist_end_block_code. + destruct (get_code_nature (i::c)) eqn:GCNIC. + - apply get_code_nature_empty in GCNIC. discriminate. + - rewrite to_bblock_size_single_label; auto. + destruct c as [|i' c]. + + contradict H. destruct i; simpl; auto. + + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. omega. + - destruct (get_code_nature c) eqn:GCNC. + + apply get_code_nature_empty in GCNC. subst. contradict H. destruct i; simpl; auto. + + contradict H. destruct c as [|i' c]; try discriminate. + destruct i'; try discriminate. + destruct i; try discriminate. all: simpl; auto. + + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. + simpl. destruct c as [|i' c]; try discriminate. + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. + cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). + unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. + rewrite to_bblock_noLabel. simpl; auto. + rewrite GCNC. discriminate. + omega. + + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. + simpl. destruct c as [|i' c]; try discriminate. + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. + cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). + unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. + rewrite to_bblock_noLabel. simpl; auto. + rewrite GCNC. discriminate. + omega. + - contradict H. destruct i; try discriminate. + all: unfold dist_end_block_code; erewrite to_bblock_CFI; eauto; simpl; eauto. +Qed. Local Hint Resolve dist_end_block_code_simu_mid_block. @@ -543,7 +542,7 @@ Proof. assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))). { unfold dist_end_block_code. remember (size _) as siz. - assert (siz <> 0%nat). rewrite Heqsiz; apply to_bblock_nonil with (c0 := c) (i := i) (c := c0); auto. + assert (siz <> 0%nat). rewrite Heqsiz; subst; apply to_bblock_nonil with (c0 := c) (i := i); auto. omega. } -- cgit From c7c06c25c608dcc57ddb16b4079c09d4c5eecd10 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 22 Aug 2018 18:42:28 +0200 Subject: a version of Asmblock syntax and semantics mixed between Machblock style and Asm... --- mppa_k1c/Asmblock.v | 1376 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1376 insertions(+) create mode 100644 mppa_k1c/Asmblock.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v new file mode 100644 index 00000000..34bce962 --- /dev/null +++ b/mppa_k1c/Asmblock.v @@ -0,0 +1,1376 @@ +(* *********************************************************************) +(* *) +(* 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 Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. + +(** * Abstract syntax *) + +(** General Purpose registers. *) + +Inductive gpreg: Type := + | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg + | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. + +Definition ireg := gpreg. +Definition freg := gpreg. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** We model the following registers of the RISC-V architecture. *) + +(** basic register *) +Inductive breg: Type := + | IR: gpreg -> breg (**r integer registers *) + | FR: gpreg -> breg (**r float registers *) + . + +Coercion IR: gpreg >-> breg. +Coercion FR: gpreg >-> breg. + +Lemma breg_eq: forall (x y: breg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. + + +Module BregEq. + Definition t := breg. + Definition eq := breg_eq. +End BregEq. + +Module Bregmap := EMap(BregEq). + +Inductive preg: Type := + | BaR: breg -> preg (**r basic registers *) + | RA: preg (**r return address *) + | PC: preg. (**r program counter *) + +Coercion BaR: breg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply breg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +Definition bpreg_get {A} (rs: Pregmap.t A): (Bregmap.t A) + := fun r => rs (BaR r). + +Definition bpreg_set {A} (rs1: Bregmap.t A) (rs2:Pregmap.t A): Pregmap.t A + := fun r => match r with BaR r => rs1 r | _ => rs2 r end. + + +(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) + +Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'FP'" := GPR10 (only parsing) : asm. +Notation "'RTMP'" := GPR31 (only parsing) : asm. + +Inductive btest: Type := + | BTdnez (**r Double Not Equal to Zero *) + | BTdeqz (**r Double Equal to Zero *) + | BTdltz (**r Double Less Than Zero *) + | 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 *) + | BTweqz (**r Word Equal to Zero *) + | BTwltz (**r Word Less Than Zero *) + | BTwgez (**r Word Greater Than or Equal to Zero *) + | BTwlez (**r Word Less Than or Equal to Zero *) + | BTwgtz (**r Word Greater Than Zero *) + . + +Inductive itest: Type := + | ITne (**r Not Equal *) + | ITeq (**r Equal *) + | ITlt (**r Less Than *) + | ITge (**r Greater Than or Equal *) + | ITle (**r Less Than or Equal *) + | ITgt (**r Greater Than *) + | ITneu (**r Unsigned Not Equal *) + | ITequ (**r Unsigned Equal *) + | ITltu (**r Less Than Unsigned *) + | 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 *) + . + +(** Offsets for load and store instructions. An offset is either an + immediate integer or the low part of a symbol. *) + +Inductive offset : Type := + | Ofsimm (ofs: ptrofs) + | Ofslow (id: ident) (ofs: ptrofs). + +(** We model a subset of the K1c instruction set. In particular, we do not + support floats yet. + + Although it is possible to use the 32-bits mode, for now we don't support it. + + We follow a design close to the one used for the Risc-V port: one set of + pseudo-instructions for 32-bit integer arithmetic, with suffix W, another + set for 64-bit integer arithmetic, with suffix L. + + When mapping to actual instructions, the OCaml code in TargetPrinter.ml + throws an error if we are not in 64-bits mode. +*) + +(** * Instructions *) + +Definition label := positive. + +(** 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 *) +Inductive ex_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 *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) +(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) + | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) + | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) +. + +(* A REVOIR: vu le traitement semantique des builtin, il faut peut-être mieux les mettre a part ? + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) +. +*) + +(** The pseudo-instructions are the following: + +- [Plabel]: define a code label at the current program point. + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Ploadli rd ival]: load an immediate 64-bit integer into an integer + register rd. Expands to a load from an address in the constant data section, + using the integer register x31 as temporary: +<< + lui x31, %hi(lbl) + ld rd, %lo(lbl)(x31) +lbl: + .quad ival +>> + +- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval + into a float register rd. + +- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval + into a float register rd. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. + +- [Pseq rd rs1 rs2]: since unsigned comparisons have particular + semantics for pointers, we cannot encode equality directly using + xor/sub etc, which have only integer semantics. +<< + xor rd, rs1, rs2 + sltiu rd, rd, 1 +>> + The [xor] is omitted if one of [rs1] and [rs2] is [x0]. + +- [Psne rd rs1 rs2]: similarly for unsigned inequality. +<< + xor rd, rs1, rs2 + sltu rd, x0, rd +>> +*) + +(** Control Flow instructions *) +Inductive cf_instruction : Type := + | 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 *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pj_l (l: label) (**r jump to label *) + (* Conditional branches *) + | 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 *) +. + +(** Loads **) +Inductive load_name_rro : Type := + | Plb (**r load byte *) + | Plbu (**r load byte unsigned *) + | Plh (**r load half word *) + | Plhu (**r load half word unsigned *) + | Plw (**r load int32 *) + | Plw_a (**r load any32 *) + | Pld (**r load int64 *) + | Pld_a (**r load any64 *) + | Pfls (**r load float *) + | Pfld (**r load 64-bit float *) +. + +Inductive ld_instruction : Type := + | PLoadRRO (i: load_name_rro) (rd: ireg) (ra: ireg) (ofs: offset) +. + +Coercion PLoadRRO: load_name_rro >-> Funclass. + +(** Stores **) +Inductive store_name_rro : Type := + | Psb (**r store byte *) + | Psh (**r store half byte *) + | Psw (**r store int32 *) + | Psw_a (**r store any32 *) + | Psd (**r store int64 *) + | Psd_a (**r store any64 *) + | Pfss (**r store float *) + | Pfsd (**r store 64-bit float *) +. + +Inductive st_instruction : Type := + | PStoreRRO (i: store_name_rro) (rs: ireg) (ra: ireg) (ofs: offset) +. + +Coercion PStoreRRO: store_name_rro >-> Funclass. + +(** Arithmetic instructions **) +Inductive arith_name_r : Type := + | Pcvtw2l (**r Convert Word to Long *) +. + +Inductive arith_name_rr : Type := + | Pmv (**r register move *) + | Pnegw (**r negate word *) + | Pnegl (**r negate long *) + | Pfnegd (**r float negate double *) + | Pcvtl2w (**r Convert Long to Word *) + | Pmvw2l (**r Move Convert Word to Long *) +. + +Inductive arith_name_ri32 : Type := + | Pmake (**r load immediate *) +. + +Inductive arith_name_ri64 : Type := + | Pmakel (**r load immediate long *) +. + +Inductive arith_name_rrr : Type := + | Pcompw (it: itest) (**r comparison word *) + | Pcompl (it: itest) (**r comparison long *) + + | Paddw (**r add word *) + | Psubw (**r sub word *) + | Pmulw (**r mul word *) + | Pandw (**r and word *) + | Porw (**r or word *) + | Pxorw (**r xor word *) + | Psraw (**r shift right arithmetic word *) + | Psrlw (**r shift right logical word *) + | Psllw (**r shift left logical word *) + + | Paddl (**r add long *) + | Psubl (**r sub long *) + | Pandl (**r and long *) + | Porl (**r or long *) + | Pxorl (**r xor long *) + | Pmull (**r mul long (low part) *) + | Pslll (**r shift left logical long *) + | Psrll (**r shift right logical long *) + | Psral (**r shift right arithmetic long *) +. + +Inductive arith_name_rri32 : Type := + | Pcompiw (it: itest) (**r comparison imm word *) + + | Paddiw (**r add imm word *) + | Pandiw (**r and imm word *) + | Poriw (**r or imm word *) + | Pxoriw (**r xor imm word *) + | Psraiw (**r shift right arithmetic imm word *) + | Psrliw (**r shift right logical imm word *) + | Pslliw (**r shift left logical imm word *) + + | Psllil (**r shift left logical immediate long *) + | Psrlil (**r shift right logical immediate long *) + | Psrail (**r shift right arithmetic immediate long *) +. + +Inductive arith_name_rri64 : Type := + | Pcompil (it: itest) (**r comparison imm long *) + | Paddil (**r add immediate long *) + | Pandil (**r and immediate long *) + | Poril (**r or immediate long *) + | Pxoril (**r xor immediate long *) +. + +Inductive ar_instruction : Type := + | PArithR (i: arith_name_r) (rd: ireg) + | PArithRR (i: arith_name_rr) (rd rs: ireg) + | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) + | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) + | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) + | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) +. + +Coercion PArithR: arith_name_r >-> Funclass. +Coercion PArithRR: arith_name_rr >-> Funclass. +Coercion PArithRI32: arith_name_ri32 >-> Funclass. +Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRRR: arith_name_rrr >-> Funclass. +Coercion PArithRRI32: arith_name_rri32 >-> Funclass. +Coercion PArithRRI64: arith_name_rri64 >-> Funclass. + +Inductive basic : Type := + | PLoad (i: ld_instruction) + | PStore (i: st_instruction) + | PArith (i: ar_instruction) +. + +Coercion PLoad: ld_instruction >-> basic. +Coercion PStore: st_instruction >-> basic. +Coercion PArith: ar_instruction >-> basic. + + +Inductive control : Type := + | PExpand (i: ex_instruction) + | PCtlFlow (i: cf_instruction) +. + +Coercion PExpand: ex_instruction >-> control. +Coercion PCtlFlow: cf_instruction >-> control. + + +(** * Definition of a bblock *) + +Definition non_empty_bblock (body: list basic) (exit: option control) + := body <> nil \/ exit <> None. (* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type ? *) + +Record bblock := mk_bblock { + header: list label; + body: list basic; + exit: option control; + correct: non_empty_bblock body exit +}. + +(* FIXME: redundant with definition in Machblock *) +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +(* WARNING: the notion of size is not the same than in Machblock ! + We ignore labels here... + The result is in Z to be compatible with operations on PC +*) +Definition size (b:bblock): Z := Z.of_nat ((length (body b))+(length_opt (exit b))). + +Lemma size_positive (b:bblock): size b > 0. +Admitted. (* TODO *) + +Definition code := list bblock. + +Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + + + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain + the convention that integer registers are mapped to values of + type [Tint] or [Tlong] (in 64 bit mode), + and float registers to values of type [Tsingle] or [Tfloat]. *) + +Definition bregset := Bregmap.t val. +Definition regset := Pregmap.t val. + +Definition bregset_cast (rs: regset): bregset + := fun r => rs (BaR r). + +Coercion bregset_cast: regset >-> bregset. + +Definition genv := Genv.t fundef unit. + +Notation "a # b" := (a b) (at level 1, only parsing) : asm. +Notation "a # b <- c" := (Bregmap.set b c a) (at level 1, b at next level) : asm. +Notation "a # b <= c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + + +(** Undefining some registers *) +(* FIXME +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <= Vundef) + end. +*) + +(** Assigning a register pair *) +Definition set_pair (p: rpair breg) (v: val) (rs: bregset) : bregset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + +(* TODO: Is it still useful ?? + +(** Assigning multiple registers *) + +Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := + match rl, vl with + | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) + | _, _ => rs + end. + +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + +*) + + +Section RELSEM. + +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [Next rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Stuck] if the processor is stuck. *) + +Inductive outcome {rgset}: Type := + | Next (rs:rgset) (m:mem) + | Stuck. +Arguments outcome: clear implicits. + + +(** ** Arithmetic Expressions (including comparisons) *) + +Inductive signedness: Type := Signed | Unsigned. + +Inductive intsize: Type := Int | Long. + +Definition itest_for_cmp (c: comparison) (s: signedness) := + match c, s with + | Cne, Signed => ITne + | Ceq, Signed => ITeq + | Clt, Signed => ITlt + | Cge, Signed => ITge + | Cle, Signed => ITle + | Cgt, Signed => ITgt + | Cne, Unsigned => ITneu + | Ceq, Unsigned => ITequ + | Clt, Unsigned => ITltu + | Cge, Unsigned => ITgeu + | Cle, Unsigned => ITleu + | Cgt, Unsigned => ITgtu + end. + +(* CoMPare Signed Words to Zero *) +Definition btest_for_cmpswz (c: comparison) := + match c with + | Cne => BTwnez + | Ceq => BTweqz + | Clt => BTwltz + | Cge => BTwgez + | Cle => BTwlez + | Cgt => BTwgtz + end. + +(* CoMPare Signed Doubles to Zero *) +Definition btest_for_cmpsdz (c: comparison) := + match c with + | Cne => BTdnez + | Ceq => BTdeqz + | Clt => BTdltz + | Cge => BTdgez + | Cle => BTdlez + | Cgt => BTdgtz + end. + +Definition cmp_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTwltz => (Some Clt, Int) + | BTwgez => (Some Cge, Int) + | BTwlez => (Some Cle, Int) + | BTwgtz => (Some Cgt, Int) + + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | BTdltz => (Some Clt, Long) + | BTdgez => (Some Cge, Long) + | BTdlez => (Some Cle, Long) + | BTdgtz => (Some Cgt, Long) + end. + +Definition cmpu_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | _ => (None, Int) + end. + +(** Comparing integers *) +Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := + match t with + | ITne => Val.cmp Cne v1 v2 + | ITeq => Val.cmp Ceq v1 v2 + | ITlt => Val.cmp Clt v1 v2 + | ITge => Val.cmp Cge v1 v2 + | ITle => Val.cmp Cle v1 v2 + | ITgt => Val.cmp Cgt v1 v2 + | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Vundef + end. + +Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := + let res := match t with + | ITne => Val.cmpl Cne v1 v2 + | ITeq => Val.cmpl Ceq v1 v2 + | ITlt => Val.cmpl Clt v1 v2 + | ITge => Val.cmpl Cge v1 v2 + | ITle => Val.cmpl Cle v1 v2 + | ITgt => Val.cmpl Cgt v1 v2 + | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Some Vundef + end in + match res with + | Some v => v + | None => Vundef + end + . +(** Execution of arith instructions + +TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... + +*) + +Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregset := + match ai with + | PArithR n d => + match n with + | Pcvtw2l => rs#d <- (Val.longofint rs#d) + end + + | PArithRR n d s => + match n with + | Pmv => rs#d <- (rs#s) + | Pnegw => rs#d <- (Val.neg rs#s) + | Pnegl => rs#d <- (Val.negl rs#s) + | Pfnegd => rs#d <- (Val.negf rs#s) + | Pcvtl2w => rs#d <- (Val.loword rs#s) + | Pmvw2l => rs#d <- (Val.longofint rs#s) + end + + | PArithRI32 n d i => + match n with + | Pmake => rs#d <- (Vint i) + end + + | PArithRI64 n d i => + match n with + | Pmakel => rs#d <- (Vlong i) + end + + | PArithRRR n d s1 s2 => + match n with + | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) + | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) + | Paddw => rs#d <- (Val.add rs#s1 rs#s2) + | Psubw => rs#d <- (Val.sub rs#s1 rs#s2) + | Pmulw => rs#d <- (Val.mul rs#s1 rs#s2) + | Pandw => rs#d <- (Val.and rs#s1 rs#s2) + | Porw => rs#d <- (Val.or rs#s1 rs#s2) + | Pxorw => rs#d <- (Val.xor rs#s1 rs#s2) + | Psrlw => rs#d <- (Val.shru rs#s1 rs#s2) + | Psraw => rs#d <- (Val.shr rs#s1 rs#s2) + | Psllw => rs#d <- (Val.shl rs#s1 rs#s2) + + | Paddl => rs#d <- (Val.addl rs#s1 rs#s2) + | Psubl => rs#d <- (Val.subl rs#s1 rs#s2) + | Pandl => rs#d <- (Val.andl rs#s1 rs#s2) + | Porl => rs#d <- (Val.orl rs#s1 rs#s2) + | Pxorl => rs#d <- (Val.xorl rs#s1 rs#s2) + | Pmull => rs#d <- (Val.mull rs#s1 rs#s2) + | Pslll => rs#d <- (Val.shll rs#s1 rs#s2) + | Psrll => rs#d <- (Val.shrlu rs#s1 rs#s2) + | Psral => rs#d <- (Val.shrl rs#s1 rs#s2) + end + + | PArithRRI32 n d s i => + match n with + | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i) m) + | Paddiw => rs#d <- (Val.add rs#s (Vint i)) + | Pandiw => rs#d <- (Val.and rs#s (Vint i)) + | Poriw => rs#d <- (Val.or rs#s (Vint i)) + | Pxoriw => rs#d <- (Val.xor rs#s (Vint i)) + | Psraiw => rs#d <- (Val.shr rs#s (Vint i)) + | Psrliw => rs#d <- (Val.shru rs#s (Vint i)) + | Pslliw => rs#d <- (Val.shl rs#s (Vint i)) + | Psllil => rs#d <- (Val.shll rs#s (Vint i)) + | Psrlil => rs#d <- (Val.shrlu rs#s (Vint i)) + | Psrail => rs#d <- (Val.shrl rs#s (Vint i)) + end + + | PArithRRI64 n d s i => + match n with + | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m) + | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) + | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) + | Poril => rs#d <- (Val.orl rs#s (Vlong i)) + | Pxoril => rs#d <- (Val.xorl rs#s (Vlong i)) + end + end. + +Variable ge: genv. + +(** * load/store *) + +(** The two functions below axiomatize how the linker processes + symbolic references [symbol + offset)] and splits their + actual values into a 20-bit high part [%hi(symbol + offset)] and + a 12-bit low part [%lo(symbol + offset)]. *) + +Parameter low_half: genv -> ident -> ptrofs -> ptrofs. +Parameter high_half: genv -> ident -> ptrofs -> val. + +(** The fundamental property of these operations is that, when applied + to the address of a symbol, their results can be recombined by + addition, rebuilding the original address. *) + +Axiom low_high_half: + forall id ofs, + Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. + +(** Auxiliaries for memory accesses *) + +Definition eval_offset (ofs: offset) : ptrofs := + match ofs with + | Ofsimm n => n + | Ofslow id delta => low_half ge id delta + end. + +Definition exec_load (chunk: memory_chunk) (rs: bregset) (m: mem) + (d: breg) (a: ireg) (ofs: offset) := + match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with + | None => Stuck + | Some v => Next (rs#d <- v) m + end. + +Definition exec_store (chunk: memory_chunk) (rs: bregset) (m: mem) + (s: breg) (a: ireg) (ofs: offset) := + match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with + | None => Stuck + | Some m' => Next rs m' + end. + +(** * basic instructions *) + +Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset := + match bi with + | PArith ai => Next (exec_arith_instr ai rs m) m + + | PLoadRRO n d a ofs => + match n with + | Plb => exec_load Mint8signed rs m d a ofs + | Plbu => exec_load Mint8unsigned rs m d a ofs + | Plh => exec_load Mint16signed rs m d a ofs + | Plhu => exec_load Mint16unsigned rs m d a ofs + | Plw => exec_load Mint32 rs m d a ofs + | Plw_a => exec_load Many32 rs m d a ofs + | Pld => exec_load Mint64 rs m d a ofs + | Pld_a => exec_load Many64 rs m d a ofs + | Pfls => exec_load Mfloat32 rs m d a ofs + | Pfld => exec_load Mfloat64 rs m d a ofs + end + + | PStoreRRO n s a ofs => + match n with + | Psb => exec_store Mint8unsigned rs m s a ofs + | Psh => exec_store Mint16unsigned rs m s a ofs + | Psw => exec_store Mint32 rs m s a ofs + | Psw_a => exec_store Many32 rs m s a ofs + | Psd => exec_store Mint64 rs m s a ofs + | Psd_a => exec_store Many64 rs m s a ofs + | Pfss => exec_store Mfloat32 rs m s a ofs + | Pfsd => exec_store Mfloat64 rs m s a ofs + end + end. + +Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := + match body with + | nil => Next rs m + | bi::body' => + match exec_basic_instr bi rs m with + | Next rs' m' => exec_body body' rs' m' + | Stuck => Stuck + end + end. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextinstr]) or branching to a label ([goto_label]). *) + +Definition nextinstr (b:bblock) (rs: regset) := + rs#PC <= (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). + +(** Looking up instructions in a code sequence by position. *) +Fixpoint find_pos (pos: Z) (c: code) {struct c} : option bblock := + match c with + | nil => None + | b :: il => + if zlt pos 0 then None + else if zeq pos 0 then Some b + else find_pos (pos - (size b)) il + end. + + +(** Position corresponding to a label *) + +(** TODO: redundant w.r.t Machblock *) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + + +(** Note: copy-paste from Machblock *) +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := + match c with + | nil => None + | b :: c' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) c' + end. + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome regset := + match label_pos lbl 0 (fn_code f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <= (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end + end. + +(** 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 regset := + match res with + | Some true => goto_label f l rs m + | Some false => Next rs m + | None => Stuck + end. + + +(** Execution of a single instruction [i] in initial state [rs] and + [m]. Return updated state. 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. + + 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 exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outcome regset := +(** Get/Set system registers *) + match ic with + | Pget rd ra => + match ra with + | RA => Next (rs#rd <= (rs#ra)) m + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rs#ra <= (rs#rd)) m + | _ => Stuck + end + +(** Branch Control Unit instructions *) + | Pret => + Next (rs#PC <= (rs#RA)) m + | Pcall s => + Next (rs#RA <= (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <= (Genv.symbol_address ge s Ptrofs.zero)) m + | Pgoto s => + Next (rs#PC <= (Genv.symbol_address ge s Ptrofs.zero)) m + | Pj_l l => + goto_label f l rs m + | Pcb bt r l => + match cmp_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs#r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs#r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + + +(** Pseudo-instructions *) + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with + | None => Stuck + | Some m2 => Next (rs #FP <= (rs SP) #SP <= sp #GPR31 <= Vundef) m2 + end + | Pfreeframe sz pos => + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (rs#SP <= v #GPR31 <= Vundef) m' + end + | _ => Stuck + end + end + | Ploadsymbol rd s ofs => + Next (rs#rd <= (Genv.symbol_address ge s ofs)) m +(*| Ploadsymbol_high rd s ofs => + Next (rs#rd <= (high_half ge s ofs)) m + | Ploadli rd i => + Next (rs#GPR31 <= Vundef #rd <= (Vlong i)) m + | Ploadfi rd f => + Next (rs#GPR31 <= Vundef #rd <= (Vfloat f)) m + | Ploadsi rd f => + Next (rs#GPR31 <= Vundef #rd <= (Vsingle f)) m + | Pbtbl r tbl => + match rs r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => goto_label f lbl (rs#GPR5 <= Vundef #GPR31 <= Vundef) m + endmap_rpair + | _ => Stuck + end +*) + +(* FIXME. + +| Pbuiltin ef args res => + Stuck (**r treated specially below *) +*) + +end. + +Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := + match exec_body (body b) rs0 m with + | Next rs' m' => + let rs1 := nextinstr b (bpreg_set rs' rs0) in + match (exit b) with + | None => Next rs1 m' + | Some ic => exec_control f ic rs1 m' + end + | Stuck => Stuck + end. + +(** Translation of the LTL/Linear/Mach view of machine registers to + the RISC-V view. Note that no LTL register maps to [X31]. This + register is reserved as temporary, to be used by the generated RV32G + code. *) + + (* FIXME - R31 is not there *) +Definition breg_of (r: mreg) : breg := + match r with + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 + | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R32 => GPR32 | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 + end. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use RISC-V registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (breg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : rpair breg := + map_rpair breg_of (loc_result sg). + +(** Execution of the instruction at [rs PC]. *) + +Inductive state: Type := + | State: regset -> mem -> state. + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bi rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_pos (Ptrofs.unsigned ofs) (fn_code f) = Some bi -> + exec_bblock f bi rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m') +(* TODO + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_bundles) = Some (A:=instruction) (Pbuiltin ef args res) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextinstr + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#GPR31 <- Vundef))) -> + step (State rs m) t (State rs' m') +*) + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (bpreg_set (set_pair (loc_external_result (ef_sig ef) ) res rs) rs)#PC <= (rs RA) -> + step (State rs m) t (State rs' m'). + +End RELSEM. + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <= (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <= Vnullptr + # RA <= Vnullptr in + Genv.init_mem p = Some m0 -> + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs PC = Vnullptr -> + rs GPR0 = Vint r -> + final_state (State rs m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +(** Determinacy of the [Asm] semantics. *) + +(* TODO. + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + split. constructor. auto. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. +*) + + +(* + +(** * Instruction dependencies, definition of a bundle + +NOTE: this would be better to do this in an other file, e.g. Asmbundle ? + +*) + +(** NOTE: in all of these dependencies definitions, we do *not* consider PC. + PC dependencies are fullfilled by the above separation in bblocks + *) + +(* (writereg i rd) holds if an instruction writes to a single register rd *) +Inductive writereg: instruction -> preg -> Prop := + | writereg_set: forall rd rs, writereg (Pset rd rs) rd + | writereg_get: forall rd rs, writereg (Pget rd rs) rd + | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd + | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd + | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd + | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd + | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd + | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd + | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd + | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd + . + +(* (nowrite i) holds if an instruction doesn't write to any register *) +Inductive nowrite: instruction -> Prop := + | nowrite_ret: nowrite Pret + | nowrite_call: forall l, nowrite (Pcall l) + | nowrite_goto: forall l, nowrite (Pgoto l) + | nowrite_jl: forall l, nowrite (Pj_l l) + | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) + | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) + | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) + | nowrite_label: forall l, nowrite (Plabel l) + . + +(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) +Inductive readregs: instruction -> list preg -> Prop := + | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) + | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) + | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) + | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) + | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) + | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) + | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) + | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) + | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) + | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) + . + +(* (noread i) holds if an instruction doesn't read any register *) +Inductive noread: instruction -> Prop := + | noread_ret: noread Pret + | noread_call: forall l, noread (Pcall l) + | noread_goto: forall l, noread (Pgoto l) + | noread_jl: forall l, noread (Pj_l l) + | noread_arith_r: forall i rd, noread (PArithR i rd) + | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) + | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) + | noread_label: forall l, noread (Plabel l) + . + +(* (wawfree i i') holds if i::i' has no WAW dependency *) +Inductive wawfree: instruction -> instruction -> Prop := + | wawfree_write: forall i rs i' rs', + writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' + | wawfree_free1: forall i i', + nowrite i -> wawfree i i' + | wawfree_free2: forall i i', + nowrite i' -> wawfree i i' + . + +(* (rawfree i i') holds if i::i' has no RAW dependency *) +Inductive rawfree: instruction -> instruction -> Prop := + | rawfree_single: forall i rd i' rs, + writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' + | rawfree_double: forall i rd i' rs rs', + writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' + | rawfree_free1: forall i i', + nowrite i -> rawfree i i' + | rawfree_free2: forall i i', + noread i' -> rawfree i i' + . + +(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) +Inductive depfree: instruction -> instruction -> Prop := + | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. + +(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) +Inductive depfreelist: instruction -> list instruction -> Prop := + | depfreelist_nil: forall i, + depfreelist i nil + | depfreelist_cons: forall i i' l, + depfreelist i l -> depfree i i' -> depfreelist i (i'::l) + . + +(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) +Inductive depfreeall: list instruction -> Prop := + | depfreeall_nil: + depfreeall nil + | depfreeall_cons: forall i l, + depfreeall l -> depfreelist i l -> depfreeall (i::l) + . + +(** NOTE: we do not verify the resource constraints of the bundles, + since not meeting them causes a failure when invoking the assembler *) + +(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) +Inductive wf_bundle: bblock -> Prop := + | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. + +Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. + +Record bundle := mk_bundle { + bd_block: bblock; + bd_correct: wf_bundle bd_block +}. + +Definition bundles := list bundle. + +Definition unbundlize (lb: list bundle) := map bd_block lb. +Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). + +Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. +Proof. + intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. +Qed. + +(** Some theorems on bundles construction *) +Lemma bundle_empty_correct: wf_bundle empty_bblock. +Proof. + constructor. auto. +Qed. + +Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. + +(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) + +Definition single_inst_block (i: instruction) := acc_block i empty_bblock. + +Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). +Proof. + intros i. unfold single_inst_block. unfold acc_block. destruct i. + all: simpl; constructor; simpl; auto. +Qed. + +Definition bundlize_inst (i: instruction) := + {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. + +Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. +Proof. + induction c as [|i c]; simpl; auto. + rewrite IHc. destruct i; simpl; auto. +Qed. + +Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). + +Fixpoint bundlize (lb: list bblock) := + match lb with + | nil => nil + | b :: lb => split_bblock b ++ bundlize lb + end. + +Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. +Proof. + intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. +Qed. + +Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. +Proof. + induction lb as [|b lb]; simpl; auto. + rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. +Qed. + +Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. +Proof. + intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. +Qed. + +Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. +Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +*) \ No newline at end of file -- cgit From 59e642a34fd6b7a2f7cc6634b7bc7687e3998330 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 23 Aug 2018 07:07:24 +0200 Subject: notation change --- mppa_k1c/Asmblock.v | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 34bce962..a289029d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -490,7 +490,7 @@ Definition genv := Genv.t fundef unit. Notation "a # b" := (a b) (at level 1, only parsing) : asm. Notation "a # b <- c" := (Bregmap.set b c a) (at level 1, b at next level) : asm. -Notation "a # b <= c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. +Notation "a # b <-- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. Open Scope asm. @@ -500,7 +500,7 @@ Open Scope asm. Fixpoint undef_regs (l: list preg) (rs: regset) : regset := match l with | nil => rs - | r :: l' => undef_regs l' (rs#r <= Vundef) + | r :: l' => undef_regs l' (rs#r <-- Vundef) end. *) @@ -834,7 +834,7 @@ Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := instruction ([nextinstr]) or branching to a label ([goto_label]). *) Definition nextinstr (b:bblock) (rs: regset) := - rs#PC <= (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). + rs#PC <-- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). (** Looking up instructions in a code sequence by position. *) Fixpoint find_pos (pos: Z) (c: code) {struct c} : option bblock := @@ -884,7 +884,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <= (Vptr b (Ptrofs.repr pos))) m + | Vptr b ofs => Next (rs#PC <-- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -919,22 +919,22 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc match ic with | Pget rd ra => match ra with - | RA => Next (rs#rd <= (rs#ra)) m + | RA => Next (rs#rd <-- (rs#ra)) m | _ => Stuck end | Pset ra rd => match ra with - | RA => Next (rs#ra <= (rs#rd)) m + | RA => Next (rs#ra <-- (rs#rd)) m | _ => Stuck end (** Branch Control Unit instructions *) | Pret => - Next (rs#PC <= (rs#RA)) m + Next (rs#PC <-- (rs#RA)) m | Pcall s => - Next (rs#RA <= (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <= (Genv.symbol_address ge s Ptrofs.zero)) m + Next (rs#RA <-- (rs#PC) #PC <-- (Genv.symbol_address ge s Ptrofs.zero)) m | Pgoto s => - Next (rs#PC <= (Genv.symbol_address ge s Ptrofs.zero)) m + Next (rs#PC <-- (Genv.symbol_address ge s Ptrofs.zero)) m | Pj_l l => goto_label f l rs m | Pcb bt r l => @@ -957,7 +957,7 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc let sp := (Vptr stk Ptrofs.zero) in match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with | None => Stuck - | Some m2 => Next (rs #FP <= (rs SP) #SP <= sp #GPR31 <= Vundef) m2 + | Some m2 => Next (rs #FP <-- (rs SP) #SP <-- sp #GPR31 <-- Vundef) m2 end | Pfreeframe sz pos => match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with @@ -967,27 +967,27 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc | Vptr stk ofs => match Mem.free m stk 0 sz with | None => Stuck - | Some m' => Next (rs#SP <= v #GPR31 <= Vundef) m' + | Some m' => Next (rs#SP <-- v #GPR31 <-- Vundef) m' end | _ => Stuck end end | Ploadsymbol rd s ofs => - Next (rs#rd <= (Genv.symbol_address ge s ofs)) m + Next (rs#rd <-- (Genv.symbol_address ge s ofs)) m (*| Ploadsymbol_high rd s ofs => - Next (rs#rd <= (high_half ge s ofs)) m + Next (rs#rd <-- (high_half ge s ofs)) m | Ploadli rd i => - Next (rs#GPR31 <= Vundef #rd <= (Vlong i)) m + Next (rs#GPR31 <-- Vundef #rd <-- (Vlong i)) m | Ploadfi rd f => - Next (rs#GPR31 <= Vundef #rd <= (Vfloat f)) m + Next (rs#GPR31 <-- Vundef #rd <-- (Vfloat f)) m | Ploadsi rd f => - Next (rs#GPR31 <= Vundef #rd <= (Vsingle f)) m + Next (rs#GPR31 <-- Vundef #rd <-- (Vsingle f)) m | Pbtbl r tbl => match rs r with | Vint n => match list_nth_z tbl (Int.unsigned n) with | None => Stuck - | Some lbl => goto_label f lbl (rs#GPR5 <= Vundef #GPR31 <= Vundef) m + | Some lbl => goto_label f lbl (rs#GPR5 <-- Vundef #GPR31 <-- Vundef) m endmap_rpair | _ => Stuck end @@ -1097,7 +1097,7 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (bpreg_set (set_pair (loc_external_result (ef_sig ef) ) res rs) rs)#PC <= (rs RA) -> + rs' = (bpreg_set (set_pair (loc_external_result (ef_sig ef) ) res rs) rs)#PC <-- (rs RA) -> step (State rs m) t (State rs' m'). End RELSEM. @@ -1109,9 +1109,9 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <= (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # SP <= Vnullptr - # RA <= Vnullptr in + # PC <-- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <-- Vnullptr + # RA <-- Vnullptr in Genv.init_mem p = Some m0 -> initial_state p (State rs0 m0). -- cgit From cef14fb32c4aaf96956efe2d69f7d467c58f789c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 23 Aug 2018 12:46:34 +0200 Subject: add comments (TODO/FIXME) --- mppa_k1c/Asmblock.v | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index a289029d..ad342717 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -33,7 +33,12 @@ Require Import Conventions. (** * Abstract syntax *) -(** General Purpose registers. *) +(** General Purpose registers. + +TODO: Au niveau Asmbloc, on pourrait peut-etre reutiliser les registres Mach au lieu des +gpreg, quitte à ajouter FP, SP, et RTMP dans les registres preg ??? + +*) Inductive gpreg: Type := | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg @@ -179,7 +184,13 @@ Definition label := positive. representable range. Of course, our K1c generator (file [Asmgen]) is careful to respect this range. *) -(** Instructions to be expanded *) +(** Instructions to be expanded + +TODO: à reclassifier ailleurs ?? + - builtin: seul dans un bloc (car on ne connaît pas à priori ses dépendances qui sont fixés dans du code Caml non certifié). + - loadsymbol: pourrait etre une instruction arithmetique. + - Pallocframe/Pfreeframe: pourraient etre des LOAD/STORE(+ARITH) en touchant FP, SP et RTMP. +*) Inductive ex_instruction : Type := (* Pseudo-instructions *) | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) @@ -192,7 +203,8 @@ Inductive ex_instruction : Type := | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) . -(* A REVOIR: vu le traitement semantique des builtin, il faut peut-être mieux les mettre a part ? +(* A REVOIR cf. ci-dessus: builtin tout seul dans un bloc (avec des labels devant). + | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) . @@ -200,8 +212,6 @@ Inductive ex_instruction : Type := (** The pseudo-instructions are the following: -- [Plabel]: define a code label at the current program point. - - [Ploadsymbol]: load the address of a symbol in an integer register. Expands to the [la] assembler pseudo-instruction, which does the right thing even if we are in PIC mode. @@ -436,7 +446,7 @@ Coercion PCtlFlow: cf_instruction >-> control. (** * Definition of a bblock *) -Definition non_empty_bblock (body: list basic) (exit: option control) +Definition non_empty_bblock (body: list basic) (exit: option control): Prop := body <> nil \/ exit <> None. (* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type ? *) Record bblock := mk_bblock { @@ -549,7 +559,7 @@ Arguments outcome: clear implicits. (** ** Arithmetic Expressions (including comparisons) *) -Inductive signedness: Type := Signed | Unsigned. +Inductive signedness: Type := Signed | Unsigned.nextinstr b (bpreg_set rs' rs0) Inductive intsize: Type := Int | Long. @@ -644,7 +654,7 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := | ITeq => Val.cmpl Ceq v1 v2 | ITlt => Val.cmpl Clt v1 v2 | ITge => Val.cmpl Cge v1 v2 - | ITle => Val.cmpl Cle v1 v2 + | ITle => Val.cmpl Cle v1 v2nextinstr b (bpreg_set rs' rs0) | ITgt => Val.cmpl Cgt v1 v2 | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 @@ -666,6 +676,8 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... +FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.valid_pointer m)" + *) Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregset := @@ -841,7 +853,7 @@ Fixpoint find_pos (pos: Z) (c: code) {struct c} : option bblock := match c with | nil => None | b :: il => - if zlt pos 0 then None + if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) else if zeq pos 0 then Some b else find_pos (pos - (size b)) il end. @@ -873,6 +885,7 @@ Proof. unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. Qed. +(** convert a label into a position in the code *) Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := match c with | nil => None @@ -902,8 +915,12 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti end. -(** Execution of a single instruction [i] in initial state [rs] and - [m]. Return updated state. For instructions that correspond tobuiltin +(** Execution of a single control-flow instruction [i] in initial state [rs] and + [m]. Return updated state. + + As above: PC is assumed to be incremented on the next block before the control-flow instruction + + 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 -- cgit From cf48df60cd3d1061e16048cb66401449ceb25587 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 23 Aug 2018 18:22:15 +0200 Subject: Some renaming on asmblock --- mppa_k1c/Asmblock.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ad342717..fe5e5661 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -87,11 +87,11 @@ End BregEq. Module Bregmap := EMap(BregEq). Inductive preg: Type := - | BaR: breg -> preg (**r basic registers *) + | BR: breg -> preg (**r basic registers *) | RA: preg (**r return address *) | PC: preg. (**r program counter *) -Coercion BaR: breg >-> preg. +Coercion BR: breg >-> preg. Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. Proof. decide equality. apply breg_eq. Defined. @@ -103,11 +103,11 @@ End PregEq. Module Pregmap := EMap(PregEq). -Definition bpreg_get {A} (rs: Pregmap.t A): (Bregmap.t A) - := fun r => rs (BaR r). +Definition pregs_to_bregs {A} (rs: Pregmap.t A): (Bregmap.t A) + := fun r => rs (BR r). -Definition bpreg_set {A} (rs1: Bregmap.t A) (rs2:Pregmap.t A): Pregmap.t A - := fun r => match r with BaR r => rs1 r | _ => rs2 r end. +Definition update_pregs {A} (rs1: Pregmap.t A) (rs2:Bregmap.t A): Pregmap.t A + := fun r => match r with BR r => rs2 r | _ => rs1 r end. (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) @@ -492,7 +492,7 @@ Definition bregset := Bregmap.t val. Definition regset := Pregmap.t val. Definition bregset_cast (rs: regset): bregset - := fun r => rs (BaR r). + := fun r => rs (BR r). Coercion bregset_cast: regset >-> bregset. @@ -559,7 +559,7 @@ Arguments outcome: clear implicits. (** ** Arithmetic Expressions (including comparisons) *) -Inductive signedness: Type := Signed | Unsigned.nextinstr b (bpreg_set rs' rs0) +Inductive signedness: Type := Signed | Unsigned. Inductive intsize: Type := Int | Long. @@ -654,7 +654,7 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := | ITeq => Val.cmpl Ceq v1 v2 | ITlt => Val.cmpl Clt v1 v2 | ITge => Val.cmpl Cge v1 v2 - | ITle => Val.cmpl Cle v1 v2nextinstr b (bpreg_set rs' rs0) + | ITle => Val.cmpl Cle v1 v2 | ITgt => Val.cmpl Cgt v1 v2 | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 @@ -1021,7 +1021,7 @@ end. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := match exec_body (body b) rs0 m with | Next rs' m' => - let rs1 := nextinstr b (bpreg_set rs' rs0) in + let rs1 := nextinstr b (update_pregs rs0 rs') in match (exit b) with | None => Next rs1 m' | Some ic => exec_control f ic rs1 m' @@ -1114,7 +1114,7 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (bpreg_set (set_pair (loc_external_result (ef_sig ef) ) res rs) rs)#PC <-- (rs RA) -> + rs' = (update_pregs rs (set_pair (loc_external_result (ef_sig ef) ) res rs))#PC <-- (rs RA) -> step (State rs m) t (State rs' m'). End RELSEM. -- cgit From 43dae2c0d39598ac948f4520ea2b057b35771964 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 24 Aug 2018 15:56:34 +0200 Subject: Name changing + introducing Pbuiltin (alone in a block) --- mppa_k1c/Asmblock.v | 158 ++++++++++++++++++++++------------------------------ 1 file changed, 67 insertions(+), 91 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fe5e5661..225fad66 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -87,11 +87,11 @@ End BregEq. Module Bregmap := EMap(BregEq). Inductive preg: Type := - | BR: breg -> preg (**r basic registers *) + | BaR: breg -> preg (**r basic registers *) | RA: preg (**r return address *) | PC: preg. (**r program counter *) -Coercion BR: breg >-> preg. +Coercion BaR: breg >-> preg. Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. Proof. decide equality. apply breg_eq. Defined. @@ -104,10 +104,10 @@ End PregEq. Module Pregmap := EMap(PregEq). Definition pregs_to_bregs {A} (rs: Pregmap.t A): (Bregmap.t A) - := fun r => rs (BR r). + := fun r => rs (BaR r). Definition update_pregs {A} (rs1: Pregmap.t A) (rs2:Bregmap.t A): Pregmap.t A - := fun r => match r with BR r => rs2 r | _ => rs1 r end. + := fun r => match r with BaR r => rs2 r | _ => rs1 r end. (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) @@ -177,6 +177,7 @@ Inductive offset : Type := 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 @@ -197,18 +198,11 @@ Inductive ex_instruction : Type := | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) (*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) - | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) - | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) -. - -(* A REVOIR cf. ci-dessus: builtin tout seul dans un bloc (avec des labels devant). | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) . -*) (** The pseudo-instructions are the following: @@ -216,22 +210,6 @@ Inductive ex_instruction : Type := Expands to the [la] assembler pseudo-instruction, which does the right thing even if we are in PIC mode. -- [Ploadli rd ival]: load an immediate 64-bit integer into an integer - register rd. Expands to a load from an address in the constant data section, - using the integer register x31 as temporary: -<< - lui x31, %hi(lbl) - ld rd, %lo(lbl)(x31) -lbl: - .quad ival ->> - -- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval - into a float register rd. - -- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval - into a float register rd. - - [Pallocframe sz pos]: in the formal semantics, this pseudo-instruction allocates a memory block with bounds [0] and [sz], stores the value of the stack pointer at offset [pos] in this @@ -266,21 +244,6 @@ lbl: table: .long table[0], table[1], ... >> Note that [reg] contains 4 times the index of the desired table entry. - -- [Pseq rd rs1 rs2]: since unsigned comparisons have particular - semantics for pointers, we cannot encode equality directly using - xor/sub etc, which have only integer semantics. -<< - xor rd, rs1, rs2 - sltiu rd, rd, 1 ->> - The [xor] is omitted if one of [rs1] and [rs2] is [x0]. - -- [Psne rd rs1 rs2]: similarly for unsigned inequality. -<< - xor rd, rs1, rs2 - sltu rd, x0, rd ->> *) (** Control Flow instructions *) @@ -289,9 +252,11 @@ Inductive cf_instruction : Type := | Pset (rd: preg) (rs: ireg) (**r set system register *) | Pret (**r return *) | Pcall (l: label) (**r function call *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) | Pgoto (l: label) (**r goto *) | Pj_l (l: label) (**r jump to label *) + (* Conditional branches *) | 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 *) @@ -449,11 +414,20 @@ Coercion PCtlFlow: cf_instruction >-> control. Definition non_empty_bblock (body: list basic) (exit: option control): Prop := body <> nil \/ exit <> None. (* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type ? *) +Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, + exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. + +Definition wf_bblock (body: list basic) (exit: option control) := + non_empty_bblock body exit /\ builtin_alone body exit. + +(** A bblock is well-formed if he contains at least one instruction, + and if there is a builtin then it must be alone in this bblock. *) + Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; - correct: non_empty_bblock body exit + correct: wf_bblock body exit }. (* FIXME: redundant with definition in Machblock *) @@ -469,8 +443,28 @@ Definition length_opt {A} (o: option A) : nat := *) Definition size (b:bblock): Z := Z.of_nat ((length (body b))+(length_opt (exit b))). +Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. +Proof. + intros. destruct l; try (contradict H; auto; fail). + simpl. omega. +Qed. + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. simpl. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. simpl. apply gt_irrefl. +Qed. + Lemma size_positive (b:bblock): size b > 0. -Admitted. (* TODO *) +Proof. + unfold size. apply to_nat_pos. rewrite Nat2Z.id. + destruct b as [h b e COR]. simpl. inversion COR. inversion H. + - assert ((length b > 0)%nat). apply length_nonil. auto. + omega. + - destruct e; simpl; try omega. contradict H; simpl; auto. +Qed. Definition code := list bblock. @@ -492,7 +486,7 @@ Definition bregset := Bregmap.t val. Definition regset := Pregmap.t val. Definition bregset_cast (rs: regset): bregset - := fun r => rs (BR r). + := fun r => rs (BaR r). Coercion bregset_cast: regset >-> bregset. @@ -506,13 +500,13 @@ Open Scope asm. (** Undefining some registers *) -(* FIXME + Fixpoint undef_regs (l: list preg) (rs: regset) : regset := match l with | nil => rs | r :: l' => undef_regs l' (rs#r <-- Vundef) end. -*) + (** Assigning a register pair *) Definition set_pair (p: rpair breg) (v: val) (rs: bregset) : bregset := @@ -521,28 +515,26 @@ Definition set_pair (p: rpair breg) (v: val) (rs: bregset) : bregset := | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) end. -(* TODO: Is it still useful ?? +(* TODO: Is it still useful ?? *) + (** Assigning multiple registers *) -Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := +(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := match rl, vl with | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) | _, _ => rs end. - + *) (** Assigning the result of a builtin *) Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := match res with - | BR r => rs#r <- v + | BR r => rs#r <-- v | BR_none => rs | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) end. -*) - - Section RELSEM. (** The semantics is purely small-step and defined as a function @@ -843,19 +835,19 @@ Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := end. (** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). *) + instruction ([nextblock]) or branching to a label ([goto_label]). *) -Definition nextinstr (b:bblock) (rs: regset) := +Definition nextblock (b:bblock) (rs: regset) := rs#PC <-- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). -(** Looking up instructions in a code sequence by position. *) -Fixpoint find_pos (pos: Z) (c: code) {struct c} : option bblock := +(** Looking up bblocks in a code sequence by position. *) +Fixpoint find_bblock (pos: Z) (c: code) {struct c} : option bblock := match c with | nil => None | b :: il => if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) else if zeq pos 0 then Some b - else find_pos (pos - (size b)) il + else find_bblock (pos - (size b)) il end. @@ -991,37 +983,14 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc end | Ploadsymbol rd s ofs => Next (rs#rd <-- (Genv.symbol_address ge s ofs)) m -(*| Ploadsymbol_high rd s ofs => - Next (rs#rd <-- (high_half ge s ofs)) m - | Ploadli rd i => - Next (rs#GPR31 <-- Vundef #rd <-- (Vlong i)) m - | Ploadfi rd f => - Next (rs#GPR31 <-- Vundef #rd <-- (Vfloat f)) m - | Ploadsi rd f => - Next (rs#GPR31 <-- Vundef #rd <-- (Vsingle f)) m - | Pbtbl r tbl => - match rs r with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => Stuck - | Some lbl => goto_label f lbl (rs#GPR5 <-- Vundef #GPR31 <-- Vundef) m - endmap_rpair - | _ => Stuck - end -*) - -(* FIXME. - -| Pbuiltin ef args res => + | Pbuiltin ef args res => Stuck (**r treated specially below *) -*) - end. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := match exec_body (body b) rs0 m with | Next rs' m' => - let rs1 := nextinstr b (update_pregs rs0 rs') in + let rs1 := nextblock b (update_pregs rs0 rs') in match (exit b) with | None => Next rs1 m' | Some ic => exec_control f ic rs1 m' @@ -1052,6 +1021,8 @@ Definition breg_of (r: mreg) : breg := | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 end. +Definition preg_of (r: mreg) : preg := breg_of r. + (** Extract the values of the arguments of an external call. We exploit the calling conventions from module [Conventions], except that we use RISC-V registers instead of locations. *) @@ -1086,28 +1057,33 @@ Definition loc_external_result (sg: signature) : rpair breg := Inductive state: Type := | State: regset -> mem -> state. + +(** TODO + * For now, we consider a builtin is alone in a basic block. + * Perhaps there is a way to avoid that ? + *) + Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f bi rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_pos (Ptrofs.unsigned ofs) (fn_code f) = Some bi -> + find_bblock (Ptrofs.unsigned ofs) (fn_code f) = Some bi -> exec_bblock f bi rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') -(* TODO | exec_step_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m', + forall b ofs f ef args res rs m vargs t vres rs' m' bi, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) f.(fn_bundles) = Some (A:=instruction) (Pbuiltin ef args res) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_code) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> eval_builtin_args ge rs (rs SP) m args vargs -> external_call ef ge vargs m t vres m' -> - rs' = nextinstr + rs' = nextblock bi (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <- Vundef))) -> + (rs#GPR31 <-- Vundef))) -> step (State rs m) t (State rs' m') -*) | exec_step_external: forall b ef args res rs m t rs' m', rs PC = Vptr b Ptrofs.zero -> -- cgit From 980f6d5b8b032fb77f867ca3404e71047b51a6d2 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 27 Aug 2018 11:35:27 +0200 Subject: deplacement allocframe/freeframe/loadsymbol dans instructions basiques des blocs. --- mppa_k1c/Asmblock.v | 78 +++++++++++++++++++++++++---------------------------- 1 file changed, 37 insertions(+), 41 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 225fad66..5bc9967c 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -33,11 +33,7 @@ Require Import Conventions. (** * Abstract syntax *) -(** General Purpose registers. - -TODO: Au niveau Asmbloc, on pourrait peut-etre reutiliser les registres Mach au lieu des -gpreg, quitte à ajouter FP, SP, et RTMP dans les registres preg ??? - +(** General Purpose registers. *) Inductive gpreg: Type := @@ -185,18 +181,10 @@ Definition label := positive. representable range. Of course, our K1c generator (file [Asmgen]) is careful to respect this range. *) -(** Instructions to be expanded - -TODO: à reclassifier ailleurs ?? - - builtin: seul dans un bloc (car on ne connaît pas à priori ses dépendances qui sont fixés dans du code Caml non certifié). - - loadsymbol: pourrait etre une instruction arithmetique. - - Pallocframe/Pfreeframe: pourraient etre des LOAD/STORE(+ARITH) en touchant FP, SP et RTMP. +(** Instructions to be expanded in control-flow *) Inductive ex_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 *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) (*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) @@ -204,7 +192,10 @@ Inductive ex_instruction : Type := -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) . -(** The pseudo-instructions are the following: +(** FIXME: comment not up to date ! + + + The pseudo-instructions are the following: - [Ploadsymbol]: load the address of a symbol in an integer register. Expands to the [la] assembler pseudo-instruction, which does the right @@ -303,6 +294,7 @@ Coercion PStoreRRO: store_name_rro >-> Funclass. (** Arithmetic instructions **) Inductive arith_name_r : Type := | Pcvtw2l (**r Convert Word to Long *) + | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) . Inductive arith_name_rr : Type := @@ -390,9 +382,11 @@ Coercion PArithRRI32: arith_name_rri32 >-> Funclass. Coercion PArithRRI64: arith_name_rri64 >-> Funclass. Inductive basic : Type := + | PArith (i: ar_instruction) | PLoad (i: ld_instruction) | PStore (i: st_instruction) - | PArith (i: ar_instruction) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) . Coercion PLoad: ld_instruction >-> basic. @@ -537,6 +531,8 @@ Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := Section RELSEM. +Variable ge: genv. + (** The semantics is purely small-step and defined as a function from the current state (a register set + a memory state) to either [Next rs' m'] where [rs'] and [m'] are the updated register @@ -677,8 +673,9 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregse | PArithR n d => match n with | Pcvtw2l => rs#d <- (Val.longofint rs#d) + | Ploadsymbol s ofs => rs#d <- (Genv.symbol_address ge s ofs) end - + | PArithRR n d s => match n with | Pmv => rs#d <- (rs#s) @@ -749,8 +746,6 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregse end end. -Variable ge: genv. - (** * load/store *) (** The two functions below axiomatize how the linker processes @@ -822,6 +817,29 @@ Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset | Pfss => exec_store Mfloat32 rs m s a ofs | Pfsd => exec_store Mfloat64 rs m s a ofs end + + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with + | None => Stuck + | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef) m2 + end + + | Pfreeframe sz pos => + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (rs#SP <- v #GPR31 <- Vundef) m' + end + | _ => Stuck + end + end + end. Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := @@ -961,28 +979,6 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc (** Pseudo-instructions *) - | Pallocframe sz pos => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with - | None => Stuck - | Some m2 => Next (rs #FP <-- (rs SP) #SP <-- sp #GPR31 <-- Vundef) m2 - end - | Pfreeframe sz pos => - match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with - | None => Stuck - | Some v => - match rs SP with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => Stuck - | Some m' => Next (rs#SP <-- v #GPR31 <-- Vundef) m' - end - | _ => Stuck - end - end - | Ploadsymbol rd s ofs => - Next (rs#rd <-- (Genv.symbol_address ge s ofs)) m | Pbuiltin ef args res => Stuck (**r treated specially below *) end. -- cgit From 96de003cd1b9e486781263a48ca10da047937c80 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 28 Aug 2018 17:51:04 +0200 Subject: Changements mineurs Asmblock.v + draft de Asmblockgen.v à compléter MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Asmblock.v: - Rajout de "header" dans wf_bblock - Remplacer "code" par "bblocks". Pour la suite, je trouve plus clair de manipuler des bblocks, plutôt qu'un "code constitué de bblocks". ça permet de minimiser les modifications dans Asmblockgen.v - fn_code --> fn_blocks . fn_code ne devrait pas être utilisé dans le code OCaml de toute façon (vu la translation Asmblock -> Asm) - Rajout d'un type instruction qui regroupe les basic et les control ; facilite certaines définitions Asmblockgen.v: - Copie conforme de Asmgen.v, avec quelques changements (pas fini). Ce vers quoi je m'oriente : garder les fonctions existantes de génération de code ; on leur donne à manger la liste de basics de Machblock. On traduit le exit (qui peut spiller sur la liste de basics déjà traduite), et on met la dernière instruction de la trad du exit (qui doit être un control) dans le exit du bblock. - Pour le prologue : chaque instruction rajoutée "à la main" est dans son propre bblock. Voir la notation ::b pour le faire. A terme, il devrait y avoir moyen "d'accumuler" l'instruction au code généré ; pour l'instant je préfère ne pas compliquer la génération. --- mppa_k1c/Asmblock.v | 54 +++- mppa_k1c/Asmblockgen.v | 857 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 899 insertions(+), 12 deletions(-) create mode 100644 mppa_k1c/Asmblockgen.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 5bc9967c..fde4569f 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -411,7 +411,7 @@ Definition non_empty_bblock (body: list basic) (exit: option control): Prop Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. -Definition wf_bblock (body: list basic) (exit: option control) := +Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := non_empty_bblock body exit /\ builtin_alone body exit. (** A bblock is well-formed if he contains at least one instruction, @@ -421,7 +421,7 @@ Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; - correct: wf_bblock body exit + correct: wf_bblock header body exit }. (* FIXME: redundant with definition in Machblock *) @@ -460,13 +460,43 @@ Proof. - destruct e; simpl; try omega. contradict H; simpl; auto. Qed. -Definition code := list bblock. +Definition bblocks := list bblock. -Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control) +. + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. + +Definition code := list instruction. + + +(** * Utility for Asmblockgen *) + +Example bblock_single_basic_correct : forall i, wf_bblock nil (i::nil) None. +Proof. + intros. split. left; discriminate. discriminate. +Qed. +Example bblock_single_control_correct : forall i, wf_bblock nil nil (Some i). +Proof. + intros. split. right; discriminate. + unfold builtin_alone. intros. auto. +Qed. + +Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None; + correct:=bblock_single_basic_correct b |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl); + correct:=bblock_single_control_correct ctl |} + end. (** * Operational semantics *) @@ -859,8 +889,8 @@ Definition nextblock (b:bblock) (rs: regset) := rs#PC <-- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). (** Looking up bblocks in a code sequence by position. *) -Fixpoint find_bblock (pos: Z) (c: code) {struct c} : option bblock := - match c with +Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := + match lb with | nil => None | b :: il => if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) @@ -896,14 +926,14 @@ Proof. Qed. (** convert a label into a position in the code *) -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with +Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := + match lb with | nil => None - | b :: c' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) c' + | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' end. Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome regset := - match label_pos lbl 0 (fn_code f) with + match label_pos lbl 0 (fn_blocks f) with | None => Stuck | Some pos => match rs#PC with @@ -1064,14 +1094,14 @@ Inductive step: state -> trace -> state -> Prop := forall b ofs f bi rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_code f) = Some bi -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> exec_bblock f bi rs m = Next rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' bi, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) f.(fn_code) = Some bi -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> exit bi = Some (PExpand (Pbuiltin ef args res)) -> eval_builtin_args ge rs (rs SP) m args vargs -> external_call ef ge vargs m t vres m' -> diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v new file mode 100644 index 00000000..5a19c451 --- /dev/null +++ b/mppa_k1c/Asmblockgen.v @@ -0,0 +1,857 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Translation from Machblock to K1c assembly language (Asmblock) *) + +Require Archi. +Require Import Coqlib Errors. +Require Import AST Integers Floats Memdata. +Require Import Op Locations Machblock Asmblock. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(** The code generation functions take advantage of several + characteristics of the [Mach] code generated by earlier passes of the + compiler, mostly that argument and result registers are of the correct + types. These properties are true by construction, but it's easier to + recheck them during code generation and fail if they do not hold. *) + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.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 ::i b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (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) (k: code) := + match make_immed32 n with + | Imm32_single imm => Pmake r imm ::i k + end. + +Definition opimm32 (op: arith_name_rrr) + (opimm: arith_name_rri32) + (rd rs: ireg) (n: int) (k: code) := + match make_immed32 n with + | Imm32_single imm => opimm rd rs imm ::i k + end. + +Definition addimm32 := opimm32 Paddw Paddiw. +Definition andimm32 := opimm32 Pandw Pandiw. +Definition orimm32 := opimm32 Porw Poriw. +Definition xorimm32 := opimm32 Pxorw Pxoriw. +(* +Definition sltimm32 := opimm32 Psltw Psltiw. +Definition sltuimm32 := opimm32 Psltuw Psltiuw. +*) + +Definition loadimm64 (r: ireg) (n: int64) (k: code) := + match make_immed64 n with + | Imm64_single imm => Pmakel r imm ::i k + end. + +Definition opimm64 (op: arith_name_rrr) + (opimm: arith_name_rri64) + (rd rs: ireg) (n: int64) (k: code) := + match make_immed64 n with + | Imm64_single imm => opimm rd rs imm ::i k +end. + +Definition addimm64 := opimm64 Paddl Paddil. +Definition orimm64 := opimm64 Porl Poril. +Definition andimm64 := opimm64 Pandl Pandil. +Definition xorimm64 := opimm64 Pxorl Pxoril. + +(* +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. +*) + +Definition cast32signed (rd rs: ireg) (k: code) := + if (ireg_eq rd rs) + then Pcvtw2l rd ::i k + else Pmvw2l rd rs ::i k + . + +Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := + if Ptrofs.eq_dec n Ptrofs.zero then + Pmv rd rs ::i k + else + addimm64 rd rs (Ptrofs.to_int64 n) k. + +(** Translation of conditional branches. *) + +Definition transl_comp + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. + +Definition transl_compl + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. + +Definition select_comp (n: int) (c: comparison) : option comparison := + if Int.eq n Int.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compuimm + (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + match select_comp n c with + | Some Ceq => Pcbu BTweqz r1 lbl ::i k + | Some Cne => Pcbu BTwnez r1 lbl ::i k + | Some _ => nil (* Never happens *) + | None => loadimm32 RTMP n (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 + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compluimm + (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + match select_compl n c with + | Some Ceq => Pcbu BTdeqz r1 lbl ::i k + | Some Cne => Pcbu BTdnez r1 lbl ::i k + | Some _ => nil (* Never happens *) + | None => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k) + end + . + +Definition transl_cbranch + (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := + match cond, args with + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compuimm n c r1 lbl k) + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Signed r1 r2 lbl k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Unsigned r1 r2 lbl k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + Pcb (btest_for_cmpswz c) r1 lbl ::i k + else + loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k) + ) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compluimm n c r1 lbl k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Signed r1 r2 lbl k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Unsigned r1 r2 lbl k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + Pcb (btest_for_cmpsdz c) r1 lbl ::i k + else + loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k) + ) +(*| Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) +*)| _, _ => + Error(msg "Asmgen.transl_cbranch") + end. + +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := + Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := + Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := + Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + +Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := + Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := + Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) +(*| Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) +*)| _, _ => + Error(msg "Asmgen.transl_cond_op") +end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (res: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmv r a ::i k) + | _ , _ => Error(msg "Asmgen.Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n k) +(*| Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfcvtdw rd GPR0 :: k + else Ploadfi rd f :: k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (if Float32.eq_dec f Float32.zero + then Pfcvtsw rd GPR0 :: k + else Ploadsi rd f :: k) +*)| Oaddrsymbol s ofs, nil => + do rd <- ireg_of res; + OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) + then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs k + else Ploadsymbol s ofs rd ::i k) + | Oaddrstack n, nil => + do rd <- ireg_of res; + OK (addptrofs rd SP n k) + + | Ocast8signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) + | Ocast16signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k) + | Oadd, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddw rd rs1 rs2 ::i k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n 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) + | 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) +(*| Omulhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhw rd rs1 rs2 :: k) + | Omulhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhuw rd rs1 rs2 :: k) + | Odiv, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivw rd rs1 rs2 :: k) + | Odivu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivuw rd rs1 rs2 :: k) + | Omod, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premw rd rs1 rs2 :: k) + | Omodu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premuw rd rs1 rs2 :: k) +*)| Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandw rd rs1 rs2 ::i k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm32 rd rs n k) + | Oor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porw rd rs1 rs2 ::i k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm32 rd rs n k) + | Oxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorw rd rs1 rs2 ::i k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs n k) + | Oshl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psllw rd rs1 rs2 ::i k) + | Oshlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs n ::i k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psraw rd rs1 rs2 ::i k) + | Oshrimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psraiw rd rs n ::i k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrlw rd rs1 rs2 ::i k) + | Oshruimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrliw rd rs n ::i k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero then Pmv rd rs ::i k else + Psraiw GPR31 rs (Int.repr 31) ::i + Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i + Paddw GPR31 rs GPR31 ::i + Psraiw rd GPR31 n ::i k) + + (* [Omakelong], [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pcvtl2w rd rs ::i k) + | Ocast32signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (cast32signed rd rs k) + | Ocast32unsigned, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + assertion (ireg_eq rd rs); + OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) + | Oaddl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddl rd rs1 rs2 ::i k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm64 rd rs n k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pnegl rd rs ::i k) + | 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) + | 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) +(*| Omullhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhl rd rs1 rs2 :: k) + | Omullhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhul rd rs1 rs2 :: k) + | Odivl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivl rd rs1 rs2 :: k) + | Odivlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivul rd rs1 rs2 :: k) + | Omodl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Preml rd rs1 rs2 :: k) + | Omodlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premul rd rs1 rs2 :: k) +*)| Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandl rd rs1 rs2 ::i k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm64 rd rs n k) + | Oorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porl rd rs1 rs2 ::i k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm64 rd rs n k) + | Oxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorl rd rs1 rs2 ::i k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs n k) + | Oshll, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pslll rd rs1 rs2 ::i k) + | Oshllimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psllil rd rs n ::i k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psral rd rs1 rs2 ::i k) + | Oshrlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrail rd rs n ::i k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrll rd rs1 rs2 ::i k) + | Oshrluimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrlil rd rs n ::i k) +(*| Oshrxlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero then Pmv rd rs :: k else + Psrail GPR31 rs (Int.repr 63) :: + Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: + Paddl GPR31 rs GPR31 :: + Psrail rd GPR31 n :: k) + +*)| Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegd rd rs ::i k) +(*| Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsd rd rs :: k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddd rd rs1 rs2 :: k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubd rd rs1 rs2 :: k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuld rd rs1 rs2 :: k) + | Odivf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivd rd rs1 rs2 :: k) + + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegs rd rs :: k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabss rd rs :: k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadds rd rs1 rs2 :: k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubs rd rs1 rs2 :: k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuls rd rs1 rs2 :: k) + | Odivfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivs rd rs1 rs2 :: k) + + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtsd rd rs :: k) + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtds rd rs :: k) + + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwd rd rs :: k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwud rd rs :: k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdw rd rs :: k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdwu rd rs :: k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtws rd rs :: k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwus rd rs :: k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsw rd rs :: k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtswu rd rs :: k) + + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtld rd rs :: k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlud rd rs :: k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdl rd rs :: k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdlu rd rs :: k) + | Olongofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtls rd rs :: k) + | Olonguofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlus rd rs :: k) + | Osingleoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsl rd rs :: k) + | Osingleoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtslu rd rs :: k) + +*)| Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + + | _, _ => + Error(msg "Asmgen.transl_op") + end. + +(** Accessing data in the stack frame. *) + +Definition indexed_memory_access + (mk_instr: ireg -> offset -> instruction) + (base: ireg) (ofs: ptrofs) (k: code) := + match make_immed64 (Ptrofs.to_int64 ofs) with + | Imm64_single imm => + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) ::i k +(*| Imm64_pair hi lo => + Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k + | Imm64_large imm => + Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k +*)end. + +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) + | _, _ => Error (msg "Asmgen.loadind") + end. + +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) + | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) + | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k) + | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k) + | _, _ => Error (msg "Asmgen.storeind") + end. + +Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := + indexed_memory_access (Pld dst) base ofs k. + +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := + indexed_memory_access (Psd src) base ofs k. + +(** Translation of memory accesses: loads, and stores. *) + +Definition transl_memory_access + (mk_instr: ireg -> offset -> instruction) + (addr: addressing) (args: list mreg) (k: code) : res (list instruction) := + match addr, args with + | Aindexed ofs, a1 :: nil => + do rs <- ireg_of a1; + OK (indexed_memory_access mk_instr rs ofs k) + | Aglobal id ofs, nil => + OK (Ploadsymbol id ofs GPR31 ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) + | Ainstack ofs, nil => + OK (indexed_memory_access mk_instr SP ofs k) + | _, _ => + Error(msg "Asmgen.transl_memory_access") + end. + +Definition transl_load (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: code) : res (list instruction) := + match chunk with + | Mint8signed => + do r <- ireg_of dst; + transl_memory_access (Plb r) addr args k + | Mint8unsigned => + do r <- ireg_of dst; + transl_memory_access (Plbu r) addr args k + | Mint16signed => + do r <- ireg_of dst; + transl_memory_access (Plh r) addr args k + | Mint16unsigned => + do r <- ireg_of dst; + transl_memory_access (Plhu r) addr args k + | Mint32 => + do r <- ireg_of dst; + transl_memory_access (Plw r) addr args k + | Mint64 => + do r <- ireg_of dst; + transl_memory_access (Pld r) addr args k + | Mfloat32 => + do r <- freg_of dst; + transl_memory_access (Pfls r) addr args k + | Mfloat64 => + do r <- freg_of dst; + transl_memory_access (Pfld r) addr args k + | _ => + Error (msg "Asmgen.transl_load") + end. + +Definition transl_store (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: code) : res (list instruction) := + match chunk with + | Mint8signed | Mint8unsigned => + do r <- ireg_of src; + transl_memory_access (Psb r) addr args k + | Mint16signed | Mint16unsigned => + do r <- ireg_of src; + transl_memory_access (Psh r) addr args k + | Mint32 => + do r <- ireg_of src; + transl_memory_access (Psw r) addr args k + | Mint64 => + do r <- ireg_of src; + transl_memory_access (Psd r) addr args k + | Mfloat32 => + do r <- freg_of src; + transl_memory_access (Pfss r) addr args k + | Mfloat64 => + do r <- freg_of src; + transl_memory_access (Pfsd r) addr args k + | _ => + Error (msg "Asmgen.transl_store") + end. + +(** Function epilogue *) + +Definition make_epilogue (f: Machblock.function) (k: code) := + loadind_ptr SP f.(fn_retaddr_ofs) GPR8 + (Pset RA GPR8 ::i Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::i k). + +(** Translation of a Mach instruction. *) + +Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) + (ep: bool) (k: code) := + match i with + | MBgetstack ofs ty dst => + loadind SP ofs ty dst k + | MBsetstack src ofs ty => + storeind src SP ofs ty k + | MBgetparam ofs ty dst => + (* load via the frame pointer if it is valid *) + do c <- loadind FP ofs ty dst k; + OK (if ep then c + else loadind_ptr SP f.(fn_link_ofs) FP c) + | MBop op args res => + transl_op op args res k + | MBload chunk addr args dst => + transl_load chunk addr args dst k + | MBstore chunk addr args src => + transl_store chunk addr args src k + end. + +Definition transl_instr_control (f: Machblock.function) (i: Machblock.control_flow_inst) + (ep: bool) : list instruction := + match i with +(*| Mcall sig (inl r) => + do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) +*)| MBcall sig (inr symb) => + OK ((Pcall symb) ::i k) +(*| Mtailcall sig (inl r) => + do r1 <- ireg_of r; + OK (make_epilogue f (Pcall :: k)) +*)| MBtailcall sig (inr symb) => + OK (make_epilogue f ((Pgoto symb) ::i k)) + | MBbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::i k) +(* | Mlabel lbl => + OK (Plabel lbl ::i k) *) + | MBgoto lbl => + OK (Pj_l lbl ::i k) + | MBcond cond args lbl => + transl_cbranch cond args lbl k +(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) +*)| MBreturn => + OK (make_epilogue f (Pret ::i k)) + (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) + | _ => + Error (msg "Asmgen.transl_instr") + 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 it1_is_parent (before: bool) (i: Machblock.basic_inst) : bool := + match i with + | MBsetstack src ofs ty => before + | MBgetparam ofs ty dst => negb (mreg_eq dst R10) + | MBop op args res => before && negb (mreg_eq res R10) + | _ => false + end. + +(** This is the naive definition that we no longer use because it + is not tail-recursive. It is kept as specification. *) + +Fixpoint transl_basic (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + match il with + | nil => OK nil + | i1 :: il' => + do k <- transl_basic f il' (it1_is_parent it1p i1); + transl_instr_basic f i1 it1p k + end. + +(** This is an equivalent definition in continuation-passing style + that runs in constant stack space. *) + +Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) + (it1p: bool) (k: code -> res code) := + match il with + | nil => k nil + | i1 :: il' => + transl_basic_rec f il' (it1_is_parent it1p i1) + (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2) + end. + +Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + 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, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +Definition transl_function (f: Machblock.function) := + do c <- transl_basic_code' f f.(Machblock.body) true; + do ex <- transl_instr_control + +Definition transl_function (f: Machblock.function) := + do c <- transl_code' f f.(Mach.fn_code) true; + OK (mkfunction f.(Mach.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i + Pget GPR8 RA ::i + storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). + +Definition transf_function (f: Mach.function) : res Asm.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Mach.program) : res Asm.program := + transform_partial_program transf_fundef p. -- cgit From e2c15a3957cfcbab1ff0aaf30a8450c3e177a30a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 29 Aug 2018 14:48:55 +0200 Subject: Asmblockgen.v finished (no proof yet) --- mppa_k1c/Asmblock.v | 61 +++++++++--- mppa_k1c/Asmblockgen.v | 265 ++++++++++++++++++++++++++++--------------------- 2 files changed, 199 insertions(+), 127 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fde4569f..5c37021d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -66,6 +66,7 @@ Proof. decide equality. Defined. Inductive breg: Type := | IR: gpreg -> breg (**r integer registers *) | FR: gpreg -> breg (**r float registers *) + | RA: breg . Coercion IR: gpreg >-> breg. @@ -84,7 +85,6 @@ Module Bregmap := EMap(BregEq). Inductive preg: Type := | BaR: breg -> preg (**r basic registers *) - | RA: preg (**r return address *) | PC: preg. (**r program counter *) Coercion BaR: breg >-> preg. @@ -239,8 +239,6 @@ table: .long table[0], table[1], ... (** Control Flow instructions *) Inductive cf_instruction : Type := - | 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 *) @@ -387,6 +385,8 @@ Inductive basic : Type := | PStore (i: st_instruction) | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Pget (rd: ireg) (rs: breg) (**r get system register *) + | Pset (rd: breg) (rs: ireg) (**r set system register *) . Coercion PLoad: ld_instruction >-> basic. @@ -475,7 +475,38 @@ Coercion PBasic: basic >-> instruction. Coercion PControl: control >-> instruction. Definition code := list instruction. +Definition bcode := list basic. +(** + Asmblockgen will have to translate a Mach control into a list of instructions of the form + i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction + These functions provide way to extract the basic / control instructions +*) + +Fixpoint extract_basic (c: code) := + match c with + | nil => nil + | PBasic i :: c => i :: (extract_basic c) + | PControl i :: c => nil + end. + +Fixpoint extract_ctl (c: code) := + match c with + | nil => None + | PBasic i :: c => extract_ctl c + | PControl i :: nil => Some i + | PControl i :: _ => None (* if the first found control instruction isn't the last *) + end. + +Example wf_bblock_exbasic_none : forall hd i c0 ctl, wf_bblock hd ((i :: c0) ++ extract_basic ctl) None. +Proof. + intros. split. left; discriminate. discriminate. +Qed. + +Example wf_bblock_exbasic_cfi : forall hd c ctl i, wf_bblock hd (c ++ extract_basic ctl) (Some (PCtlFlow i)). +Proof. + intros. split. right; discriminate. discriminate. +Qed. (** * Utility for Asmblockgen *) @@ -869,8 +900,17 @@ Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset | _ => Stuck end end - - end. + | Pget rd ra => + match ra with + | RA => Next (rs#rd <- (rs#ra)) m + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rs#ra <- (rs#rd)) m + | _ => Stuck + end +end. Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := match body with @@ -974,16 +1014,7 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outcome regset := (** Get/Set system registers *) match ic with - | Pget rd ra => - match ra with - | RA => Next (rs#rd <-- (rs#ra)) m - | _ => Stuck - end - | Pset ra rd => - match ra with - | RA => Next (rs#ra <-- (rs#rd)) m - | _ => Stuck - end + (** Branch Control Unit instructions *) | Pret => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5a19c451..ce2b4591 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -58,7 +58,8 @@ Inductive immed64 : Type := (* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. -Notation "a ::i b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::: b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). (** Smart constructors for arithmetic operations involving @@ -67,16 +68,16 @@ Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associ are generated as required to perform the operation and prepended to the given instruction sequence [k]. *) -Definition loadimm32 (r: ireg) (n: int) (k: code) := +Definition loadimm32 (r: ireg) (n: int) := match make_immed32 n with - | Imm32_single imm => Pmake r imm ::i k + | Imm32_single imm => Pmake r imm end. Definition opimm32 (op: arith_name_rrr) (opimm: arith_name_rri32) - (rd rs: ireg) (n: int) (k: code) := + (rd rs: ireg) (n: int) := match make_immed32 n with - | Imm32_single imm => opimm rd rs imm ::i k + | Imm32_single imm => opimm rd rs imm end. Definition addimm32 := opimm32 Paddw Paddiw. @@ -88,16 +89,16 @@ Definition sltimm32 := opimm32 Psltw Psltiw. Definition sltuimm32 := opimm32 Psltuw Psltiuw. *) -Definition loadimm64 (r: ireg) (n: int64) (k: code) := +Definition loadimm64 (r: ireg) (n: int64) := match make_immed64 n with - | Imm64_single imm => Pmakel r imm ::i k + | Imm64_single imm => Pmakel r imm end. Definition opimm64 (op: arith_name_rrr) (opimm: arith_name_rri64) - (rd rs: ireg) (n: int64) (k: code) := + (rd rs: ireg) (n: int64) := match make_immed64 n with - | Imm64_single imm => opimm rd rs imm ::i k + | Imm64_single imm => opimm rd rs imm end. Definition addimm64 := opimm64 Paddl Paddil. @@ -110,27 +111,27 @@ Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. *) -Definition cast32signed (rd rs: ireg) (k: code) := +Definition cast32signed (rd rs: ireg) := if (ireg_eq rd rs) - then Pcvtw2l rd ::i k - else Pmvw2l rd rs ::i k + then Pcvtw2l rd + else Pmvw2l rd rs . -Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := +Definition addptrofs (rd rs: ireg) (n: ptrofs) := if Ptrofs.eq_dec n Ptrofs.zero then - Pmv rd rs ::i k + Pmv rd rs else - addimm64 rd rs (Ptrofs.to_int64 n) k. + addimm64 rd rs (Ptrofs.to_int64 n). (** Translation of conditional branches. *) Definition transl_comp (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompw (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::: Pcb BTwnez RTMP lbl ::: k. Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompl (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::: Pcb BTwnez RTMP lbl ::: k. Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then @@ -146,10 +147,10 @@ Definition select_comp (n: int) (c: comparison) : option comparison := Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl ::i k - | Some Cne => Pcbu BTwnez r1 lbl ::i k + | Some Ceq => Pcbu BTweqz r1 lbl ::: k + | Some Cne => Pcbu BTwnez r1 lbl ::: k | Some _ => nil (* Never happens *) - | None => loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k) + | None => loadimm32 RTMP n ::: (transl_comp c Unsigned r1 RTMP lbl k) end . @@ -167,10 +168,10 @@ Definition select_compl (n: int64) (c: comparison) : option comparison := Definition transl_opt_compluimm (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_compl n c with - | Some Ceq => Pcbu BTdeqz r1 lbl ::i k - | Some Cne => Pcbu BTdnez r1 lbl ::i k + | Some Ceq => Pcbu BTdeqz r1 lbl ::: k + | Some Cne => Pcbu BTdnez r1 lbl ::: k | Some _ => nil (* Never happens *) - | None => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k) + | None => loadimm64 RTMP n ::: (transl_compl c Unsigned r1 RTMP lbl k) end . @@ -189,9 +190,9 @@ Definition transl_cbranch | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq n Int.zero then - Pcb (btest_for_cmpswz c) r1 lbl ::i k + Pcb (btest_for_cmpswz c) r1 lbl ::: k else - loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k) + loadimm32 RTMP n ::: (transl_comp c Signed r1 RTMP lbl k) ) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; @@ -205,9 +206,9 @@ Definition transl_cbranch | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int64.eq n Int64.zero then - Pcb (btest_for_cmpsdz c) r1 lbl ::i k + Pcb (btest_for_cmpsdz c) r1 lbl ::: k else - loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k) + loadimm64 RTMP n ::: (transl_compl c Signed r1 RTMP lbl k) ) (*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; @@ -233,32 +234,32 @@ Definition transl_cbranch [rd] target register to 0 or 1 depending on the truth value of the condition. *) -Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) := +Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. -Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := +Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. -Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := +Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. -Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := +Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. -Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := +Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. -Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := +Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. -Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := +Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. -Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := +Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with | Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; @@ -308,7 +309,7 @@ end. The corresponding instructions are prepended to [k]. *) Definition transl_op - (op: operation) (args: list mreg) (res: mreg) (k: code) := + (op: operation) (args: list mreg) (res: mreg) (k: bcode) := match op, args with | Omove, a1 :: nil => match preg_of res, preg_of a1 with @@ -317,10 +318,10 @@ Definition transl_op end | Ointconst n, nil => do rd <- ireg_of res; - OK (loadimm32 rd n k) + OK (loadimm32 rd n ::i k) | Olongconst n, nil => do rd <- ireg_of res; - OK (loadimm64 rd n k) + OK (loadimm64 rd n ::i k) (*| Ofloatconst f, nil => do rd <- freg_of res; OK (if Float.eq_dec f Float.zero @@ -334,11 +335,11 @@ Definition transl_op *)| Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) - then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs k + then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k else Ploadsymbol s ofs rd ::i k) | Oaddrstack n, nil => do rd <- ireg_of res; - OK (addptrofs rd SP n k) + OK (addptrofs rd SP n ::i k) | Ocast8signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -351,7 +352,7 @@ Definition transl_op OK (Paddw rd rs1 rs2 ::i k) | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm32 rd rs n k) + OK (addimm32 rd rs n ::i k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs ::i k) @@ -384,19 +385,19 @@ Definition transl_op OK (Pandw rd rs1 rs2 ::i k) | Oandimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm32 rd rs n k) + OK (andimm32 rd rs n ::i k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 ::i k) | Oorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm32 rd rs n k) + OK (orimm32 rd rs n ::i k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorw rd rs1 rs2 ::i k) | Oxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs n k) + OK (xorimm32 rd rs n ::i k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 ::i k) @@ -429,7 +430,7 @@ Definition transl_op OK (Pcvtl2w rd rs ::i k) | Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (cast32signed rd rs k) + OK (cast32signed rd rs ::i k) | Ocast32unsigned, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); @@ -439,7 +440,7 @@ Definition transl_op OK (Paddl rd rs1 rs2 ::i k) | Oaddlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm64 rd rs n k) + OK (addimm64 rd rs n ::i k) | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegl rd rs ::i k) @@ -472,19 +473,19 @@ Definition transl_op OK (Pandl rd rs1 rs2 ::i k) | Oandlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm64 rd rs n k) + OK (andimm64 rd rs n ::i k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 ::i k) | Oorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm64 rd rs n k) + OK (orimm64 rd rs n ::i k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 ::i k) | Oxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs n k) + OK (xorimm64 rd rs n ::i k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 ::i k) @@ -617,64 +618,64 @@ Definition transl_op (** Accessing data in the stack frame. *) Definition indexed_memory_access - (mk_instr: ireg -> offset -> instruction) - (base: ireg) (ofs: ptrofs) (k: code) := + (mk_instr: ireg -> offset -> basic) + (base: ireg) (ofs: ptrofs) := match make_immed64 (Ptrofs.to_int64 ofs) with | Imm64_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) ::i k + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) (*| Imm64_pair hi lo => Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k | Imm64_large imm => Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k *)end. -Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := +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 (Plw rd) base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) + | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k) | _, _ => Error (msg "Asmgen.loadind") end. -Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := match ty, preg_of src with - | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k) + | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k) | _, _ => Error (msg "Asmgen.storeind") end. -Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := - indexed_memory_access (Pld dst) base ofs k. +Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := + indexed_memory_access (Pld dst) base ofs. -Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := - indexed_memory_access (Psd src) base ofs k. +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + indexed_memory_access (Psd src) base ofs. (** Translation of memory accesses: loads, and stores. *) Definition transl_memory_access - (mk_instr: ireg -> offset -> instruction) - (addr: addressing) (args: list mreg) (k: code) : res (list instruction) := + (mk_instr: ireg -> offset -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := match addr, args with | Aindexed ofs, a1 :: nil => do rs <- ireg_of a1; - OK (indexed_memory_access mk_instr rs ofs k) + OK (indexed_memory_access mk_instr rs ofs ::i k) | Aglobal id ofs, nil => OK (Ploadsymbol id ofs GPR31 ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) | Ainstack ofs, nil => - OK (indexed_memory_access mk_instr SP ofs k) + OK (indexed_memory_access mk_instr SP ofs ::i k) | _, _ => Error(msg "Asmgen.transl_memory_access") end. Definition transl_load (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: code) : res (list instruction) := + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := match chunk with | Mint8signed => do r <- ireg_of dst; @@ -705,7 +706,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) end. Definition transl_store (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: code) : res (list instruction) := + (args: list mreg) (src: mreg) (k: bcode) : res bcode := match chunk with | Mint8signed | Mint8unsigned => do r <- ireg_of src; @@ -732,13 +733,13 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) (** Function epilogue *) Definition make_epilogue (f: Machblock.function) (k: code) := - loadind_ptr SP f.(fn_retaddr_ofs) GPR8 - (Pset RA GPR8 ::i Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::i k). + (loadind_ptr SP f.(fn_retaddr_ofs) GPR8) + ::: Pset RA GPR8 ::: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::: k. (** Translation of a Mach instruction. *) Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) - (ep: bool) (k: code) := + (ep: bool) (k: bcode) := match i with | MBgetstack ofs ty dst => loadind SP ofs ty dst k @@ -748,7 +749,7 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) (* load via the frame pointer if it is valid *) do c <- loadind FP ofs ty dst k; OK (if ep then c - else loadind_ptr SP f.(fn_link_ofs) FP c) + 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 => @@ -757,32 +758,36 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) transl_store chunk addr args src k end. -Definition transl_instr_control (f: Machblock.function) (i: Machblock.control_flow_inst) - (ep: bool) : list instruction := - match i with +Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst) + (ep: bool) : res code := + match oi with + | None => OK nil + | Some i => + match i with (*| Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) -*)| MBcall sig (inr symb) => - OK ((Pcall symb) ::i k) +*) | MBcall sig (inr symb) => + OK ((Pcall symb) ::: nil) (*| Mtailcall sig (inl r) => do r1 <- ireg_of r; OK (make_epilogue f (Pcall :: k)) -*)| MBtailcall sig (inr symb) => - OK (make_epilogue f ((Pgoto symb) ::i k)) - | MBbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::i k) +*) | MBtailcall sig (inr symb) => + OK (make_epilogue f ((Pgoto symb) ::: nil)) + | MBbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::: nil) (* | Mlabel lbl => OK (Plabel lbl ::i k) *) - | MBgoto lbl => - OK (Pj_l lbl ::i k) - | MBcond cond args lbl => - transl_cbranch cond args lbl k + | MBgoto lbl => + OK (Pj_l lbl ::: nil) + | MBcond cond args lbl => + transl_cbranch cond args lbl nil (*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) -*)| MBreturn => - OK (make_epilogue f (Pret ::i k)) +*) | MBreturn => + OK (make_epilogue f (Pret ::: nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) - | _ => - Error (msg "Asmgen.transl_instr") + | _ => + Error (msg "Asmgen.transl_instr") + end end. (* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme : @@ -817,7 +822,7 @@ Fixpoint transl_basic (f: Machblock.function) (il: list Machblock.basic_inst) (i that runs in constant stack space. *) Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) - (it1p: bool) (k: code -> res code) := + (it1p: bool) (k: bcode -> res bcode) := match il with | nil => k nil | i1 :: il' => @@ -833,25 +838,61 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -Definition transl_function (f: Machblock.function) := - do c <- transl_basic_code' f f.(Machblock.body) true; - do ex <- transl_instr_control +(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) +Fixpoint gen_bblocks_rec (fuel: nat) (hd: list label) (c: list basic) (ctl: list instruction) := + match fuel with + | O => nil + | (Datatypes.S) n => + match (extract_ctl ctl) with + | None => + match c with + | nil => nil (* empty block should not happen *) + | i::c => {| header := hd; body := (i::c) ++ (extract_basic ctl); exit := None; + correct := wf_bblock_exbasic_none hd i c ctl |} :: nil + end + | Some (PExpand (Pbuiltin ef args res)) => (gen_bblocks_rec n hd c nil) ++ + ((PExpand (Pbuiltin ef args res)) ::b nil) + | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i); + correct := wf_bblock_exbasic_cfi hd c ctl i |} :: nil + end + end. -Definition transl_function (f: Machblock.function) := - do c <- transl_code' f f.(Mach.fn_code) true; - OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i - Pget GPR8 RA ::i - storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). +Definition gen_bblocks := gen_bblocks_rec 42. -Definition transf_function (f: Mach.function) : res Asm.function := +Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := + do c <- transl_basic_code' f fb.(Machblock.body) true; + do ctl <- transl_instr_control f fb.(Machblock.exit) true; + OK (gen_bblocks fb.(Machblock.header) c ctl) +. + +Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) := + match lmb with + | nil => OK nil + | mb :: lmb => + do lb <- transl_block f mb; + do lb' <- transl_blocks f lmb; + OK (lb ++ lb') + end +. + +Definition transl_function (f: Machblock.function) := + do lb <- transl_blocks f f.(Machblock.fn_code); + OK (mkfunction f.(Machblock.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b + Pget GPR8 RA ::b + storeind_ptr GPR8 SP f.(fn_retaddr_ofs) ::b lb)). + +(* TODO TODO - move this check to Asm *) +(* Definition transf_function (f: Machblock.function) : res Asmblock.function := do tf <- transl_function f; if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) then Error (msg "code size exceeded") else OK tf. + *) + -Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := - transf_partial_fundef transf_function f. +Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := + transf_partial_fundef transl_function f. -Definition transf_program (p: Mach.program) : res Asm.program := +Definition transf_program (p: Machblock.program) : res Asmblock.program := transform_partial_program transf_fundef p. -- cgit From 63737a502b0f0b6c1369641e9d3d9f05712e74f7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 29 Aug 2018 16:50:23 +0200 Subject: Asmblock: Adding forward_simulation and determinism as axioms --- mppa_k1c/Asmblock.v | 2 + mppa_k1c/Asmblockgen.v | 38 +- mppa_k1c/Asmblockgenproof.v | 1124 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1145 insertions(+), 19 deletions(-) create mode 100644 mppa_k1c/Asmblockgenproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 5c37021d..c83867f1 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1174,6 +1174,8 @@ Inductive final_state: state -> int -> Prop := Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). +Axiom semantics_determinate: forall p, determinate (semantics p). + (** Determinacy of the [Asm] semantics. *) (* TODO. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ce2b4591..c55e6d94 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -58,7 +58,7 @@ Inductive immed64 : Type := (* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. -Notation "a ::: b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). @@ -127,11 +127,11 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) := Definition transl_comp (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompw (itest_for_cmp c s) RTMP r1 r2 ::: Pcb BTwnez RTMP lbl ::: k. + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompl (itest_for_cmp c s) RTMP r1 r2 ::: Pcb BTwnez RTMP lbl ::: k. + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then @@ -147,10 +147,10 @@ Definition select_comp (n: int) (c: comparison) : option comparison := Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl ::: k - | Some Cne => Pcbu BTwnez r1 lbl ::: k + | Some Ceq => Pcbu BTweqz r1 lbl ::g k + | Some Cne => Pcbu BTwnez r1 lbl ::g k | Some _ => nil (* Never happens *) - | None => loadimm32 RTMP n ::: (transl_comp c Unsigned r1 RTMP lbl k) + | None => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) end . @@ -168,10 +168,10 @@ Definition select_compl (n: int64) (c: comparison) : option comparison := Definition transl_opt_compluimm (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := match select_compl n c with - | Some Ceq => Pcbu BTdeqz r1 lbl ::: k - | Some Cne => Pcbu BTdnez r1 lbl ::: k + | Some Ceq => Pcbu BTdeqz r1 lbl ::g k + | Some Cne => Pcbu BTdnez r1 lbl ::g k | Some _ => nil (* Never happens *) - | None => loadimm64 RTMP n ::: (transl_compl c Unsigned r1 RTMP lbl k) + | None => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) end . @@ -190,9 +190,9 @@ Definition transl_cbranch | Ccompimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int.eq n Int.zero then - Pcb (btest_for_cmpswz c) r1 lbl ::: k + Pcb (btest_for_cmpswz c) r1 lbl ::g k else - loadimm32 RTMP n ::: (transl_comp c Signed r1 RTMP lbl k) + loadimm32 RTMP n ::g (transl_comp c Signed r1 RTMP lbl k) ) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; @@ -206,9 +206,9 @@ Definition transl_cbranch | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (if Int64.eq n Int64.zero then - Pcb (btest_for_cmpsdz c) r1 lbl ::: k + Pcb (btest_for_cmpsdz c) r1 lbl ::g k else - loadimm64 RTMP n ::: (transl_compl c Signed r1 RTMP lbl k) + loadimm64 RTMP n ::g (transl_compl c Signed r1 RTMP lbl k) ) (*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; @@ -734,7 +734,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) Definition make_epilogue (f: Machblock.function) (k: code) := (loadind_ptr SP f.(fn_retaddr_ofs) GPR8) - ::: Pset RA GPR8 ::: Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::: k. + ::g Pset RA GPR8 ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. (** Translation of a Mach instruction. *) @@ -767,23 +767,23 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co (*| Mcall sig (inl r) => do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) *) | MBcall sig (inr symb) => - OK ((Pcall symb) ::: nil) + OK ((Pcall symb) ::g nil) (*| Mtailcall sig (inl r) => do r1 <- ireg_of r; OK (make_epilogue f (Pcall :: k)) *) | MBtailcall sig (inr symb) => - OK (make_epilogue f ((Pgoto symb) ::: nil)) + OK (make_epilogue f ((Pgoto symb) ::g nil)) | MBbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::: nil) + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) (* | Mlabel lbl => OK (Plabel lbl ::i k) *) | MBgoto lbl => - OK (Pj_l lbl ::: nil) + OK (Pj_l lbl ::g nil) | MBcond cond args lbl => transl_cbranch cond args lbl nil (*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) *) | MBreturn => - OK (make_epilogue f (Pret ::: nil)) + OK (make_epilogue f (Pret ::g nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | _ => Error (msg "Asmgen.transl_instr") diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v new file mode 100644 index 00000000..d98e4cd3 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof.v @@ -0,0 +1,1124 @@ +(* *********************************************************************) +(* *) +(* 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 Asmgen Asmgenproof0 Asmgenproof1. *) +Require Import Asmblockgen. + +Definition match_prog (p: Machblock.program) (tp: Asmblock.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: Asmblock.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +(* Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + *) +(** * Properties of control flow *) + +(* Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + omega. +Qed. + +Lemma exec_straight_exec: + forall fb f c ep tf tc c' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + exec_straight tge tf tc rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inv H. + eapply exec_straight_steps_1; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c ep tf tc c' ep' tc' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + transl_code f c' ep' = OK tc' -> + exec_straight tge tf tc rs m tc' rs' m' -> + transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. +Proof. + intros. inv H. + exploit exec_straight_steps_2; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + *) +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +(* Remark loadimm32_label: + forall r n k, tail_nolabel k (loadimm32 r n k). +Proof. + intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) +Qed. +Hint Resolve loadimm32_label: labels. + +Remark opimm32_label: + forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm32 op opimm r1 r2 n k). +Proof. + intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) +Qed. +Hint Resolve opimm32_label: labels. + +Remark loadimm64_label: + forall r n k, tail_nolabel k (loadimm64 r n k). +Proof. + intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) +Qed. +Hint Resolve loadimm64_label: labels. + +Remark cast32signed_label: + forall rd rs k, tail_nolabel k (cast32signed rd rs k). +Proof. + intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. +Qed. +Hint Resolve cast32signed_label: labels. + +Remark opimm64_label: + forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm64 op opimm r1 r2 n k). +Proof. + intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) +Qed. +Hint Resolve opimm64_label: labels. + +Remark addptrofs_label: + forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). +Proof. + unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. + apply opimm64_label; TailNoLabel. +Qed. +Hint Resolve addptrofs_label: labels. +(* +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. +Qed. +*) +Remark transl_cbranch_label: + forall cond args lbl k c, + transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. +(* Ccomp *) + - unfold transl_comp; TailNoLabel. +(* Ccompu *) + - unfold transl_comp; TailNoLabel. +(* Ccompimm *) + - destruct (Int.eq n Int.zero); TailNoLabel. + unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. +(* Ccompuimm *) + - unfold transl_opt_compuimm. + remember (select_comp n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; + destruct (Int.eq n Int.zero); destruct c0; discriminate. + + unfold loadimm32; + destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. +(* Ccompl *) + - unfold transl_compl; TailNoLabel. +(* Ccomplu *) + - unfold transl_compl; TailNoLabel. +(* Ccomplimm *) + - destruct (Int64.eq n Int64.zero); TailNoLabel. + unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. +(* Ccompluimm *) + - unfold transl_opt_compluimm. + remember (select_compl n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; + destruct (Int64.eq n Int64.zero); destruct c0; discriminate. + + unfold loadimm64; + destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. +Qed. + +(* +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +*) + +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. +Qed. + +Remark transl_op_label: + forall op args r k c, + transl_op op args r k = OK c -> tail_nolabel k c. +Proof. +Opaque Int.eq. + unfold transl_op; intros; destruct op; TailNoLabel. +(* Omove *) +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +(* Oaddrsymbol *) +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. +(* Oaddimm32 *) +- apply opimm32_label; intros; exact I. +(* Oandimm32 *) +- apply opimm32_label; intros; exact I. +(* Oorimm32 *) +- apply opimm32_label; intros; exact I. +(* Oxorimm32 *) +- apply opimm32_label; intros; exact I. +(* Oshrximm *) +- destruct (Int.eq n Int.zero); TailNoLabel. +(* Oaddimm64 *) +- apply opimm64_label; intros; exact I. +(* Oandimm64 *) +- apply opimm64_label; intros; exact I. +(* Oorimm64 *) +- apply opimm64_label; intros; exact I. +(* Oxorimm64 *) +- apply opimm64_label; intros; exact I. +(* Ocmp *) +- eapply transl_cond_op_label; eauto. +Qed. + +(* +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. ++ TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- eapply transl_cond_op_label; eauto. +*) + +Remark indexed_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) base ofs k, + (forall r o, nolabel (mk_instr r o)) -> + tail_nolabel k (indexed_memory_access mk_instr base ofs k). +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64. *) + destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. + (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) +Qed. + +Remark loadind_label: + forall base ofs ty dst k c, + loadind base ofs ty dst k = OK c -> tail_nolabel k c. +Proof. + unfold loadind; intros. + destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark storeind_label: + forall src base ofs ty k c, + storeind src base ofs ty k = OK c -> tail_nolabel k c. +Proof. + unfold storeind; intros. + destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark loadind_ptr_label: + forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark storeind_ptr_label: + forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark transl_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) addr args k c, + (forall r o, nolabel (mk_instr r o)) -> + transl_memory_access mk_instr addr args k = OK c -> + tail_nolabel k c. +Proof. + unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. +Qed. + +Remark make_epilogue_label: + forall f k, tail_nolabel k (make_epilogue f k). +Proof. + unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. +Qed. + +Lemma transl_instr_label: + forall f i ep k c, + transl_instr f i ep k = OK c -> + match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. +Proof. + unfold transl_instr; intros; destruct i; TailNoLabel. +(* loadind *) +- eapply loadind_label; eauto. +(* storeind *) +- eapply storeind_label; eauto. +(* Mgetparam *) +- destruct ep. eapply loadind_label; eauto. + eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. +(* transl_op *) +- eapply transl_op_label; eauto. +(* transl_load *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +(* transl store *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct s0; monadInv H; TailNoLabel. +- destruct s0; monadInv H; eapply tail_nolabel_trans + ; [eapply make_epilogue_label|TailNoLabel]. +- eapply transl_cbranch_label; eauto. +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +Qed. +(* + + +- eapply transl_op_label; eauto. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +*) + +Lemma transl_instr_label': + forall lbl f i ep k c, + transl_instr f i ep k = OK c -> + find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply B). + intros. subst c. simpl. auto. +Qed. + +Lemma transl_code_label: + forall lbl f c ep tc, + transl_code f c ep = OK tc -> + match Mach.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). + generalize (Mach.is_label_correct lbl a). + destruct (Mach.is_label lbl a); intros. + subst a. simpl in EQ. exists x; auto. + eapply IHc; eauto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match Mach.find_label lbl f.(Mach.fn_code) with + | None => find_label lbl tf.(fn_code) = None + | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. + simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. + (* destruct B. *) + eapply transl_code_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 -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros [tc [A B]]. + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmgenproof0.return_address_exists; eauto. +- intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. + rewrite transl_code'_transl_code in EQ0. + exists x; exists true; split; auto. unfold fn_code. + constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x). +- 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. +*) + +Definition match_stack : Machblock.genv -> list stackframe -> Prop := (fun x y => False). + +Definition transl_code_at_pc : + Machblock.genv -> val -> block -> Machblock.function -> Machblock.code -> bool -> function -> code -> Prop + := (fun a b c d e f g h => False). + +Definition agree : Mach.regset -> val -> regset -> Prop := (fun a b c => False). + +Inductive match_states: Machblock.state -> Asmblock.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) + (Asmblock.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) + (Asmblock.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) + (Asmblock.State rs m'). +(* +Lemma exec_straight_steps: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists rs2, + exec_straight tge tf c rs1 m1' k rs2 m2' + /\ agree ms2 sp rs2 + /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c ms2 m2) st'. +Proof. + intros. inversion H2. subst. monadInv H7. + exploit H3; eauto. intros [rs2 [A [B C]]]. + exists (State rs2 m2'); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. + +Lemma exec_straight_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +Lemma exec_straight_opt_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + inv A. +- exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +- exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. *) + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the 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. *) + +Definition measure (s: Mach.state) : nat := + match s with + | Mach.State _ _ _ _ _ _ => 0%nat + | Mach.Callstate _ _ _ _ => 0%nat + | Mach.Returnstate _ _ _ => 1%nat + end. +(* +Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of R10). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. *) + +(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) +(* +Theorem step_simulation: + forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + +- (* Mlabel *) + left; eapply exec_straight_steps; eauto; intros. + monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. apply agree_nextinstr; auto. simpl; congruence. + +- (* Mgetstack *) + unfold load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto with asmgen. congruence. + simpl; congruence. + + +- (* Msetstack *) + unfold store_stack in H. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + left; eapply exec_straight_steps; eauto. + rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. + inversion TR. + exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exists rs'; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. + +- (* Mgetparam *) + assert (f0 = f) by congruence; subst f0. + unfold load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. +(* Opaque loadind. *) + left; eapply exec_straight_steps; eauto; intros. monadInv TR. + destruct ep. +(* GPR31 contains parent *) + exploit loadind_correct. eexact EQ. + instantiate (2 := rs0). rewrite DXP; eauto. congruence. + intros [rs1 [P [Q R]]]. + exists rs1; split. eauto. + split. 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. congruence. intros [rs1 [P [Q R]]]. + exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. + intros [rs2 [S [T U]]]. + exists rs2; split. eapply exec_straight_trans; eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs1#FP <- (rs2#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. +- (* Mop *) + assert (eval_operation tge sp op (map rs args) m = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. split. auto. + apply agree_set_undef_mreg with rs0; 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. + +- (* Mload *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + inversion TR. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. + split. eapply agree_set_undef_mreg; eauto. congruence. + intros; auto with asmgen. + simpl; congruence. + + +- (* Mstore *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + left; eapply exec_straight_steps; eauto. + intros. simpl in TR. + inversion TR. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + exists rs2; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; congruence. + +- (* Mcall *) + assert (f0 = f) by congruence. subst f0. + inv AT. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct ros as [rf|fid]; simpl in H; monadInv H5. +(* ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. +*) ++ (* Direct call *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + +- (* Mtailcall *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. + destruct ros as [rf|fid]; simpl in H; monadInv H7. +(* ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. +*) ++ (* Direct call *) + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + 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 H. auto. } + +- (* Mbuiltin *) + inv AT. monadInv H4. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + left. econstructor; split. apply plus_one. + eapply exec_step_builtin. eauto. eauto. + eapply find_instr_tail; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H1. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. + congruence. + +- (* Mgoto *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H4. + exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. + left; exists (State rs' m'); split. + apply plus_one. econstructor; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + econstructor; eauto. + eapply agree_exten; eauto with asmgen. + congruence. +- (* Mcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_opt_steps_goto; eauto. + intros. simpl in TR. + inversion TR. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exists jmp; exists k; exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + exact B. +- (* Mcond false *) + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + inversion TR. + exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). + exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + simpl. congruence. +- (* Mjumptable *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H6. +(* + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H5); intro NOOV. + exploit find_label_goto_label. eauto. eauto. + instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). + Simpl. eauto. + eauto. + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H. intros LD; inv LD. + left; econstructor; split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail; eauto. + simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. + econstructor; eauto. + eapply agree_undef_regs; eauto. + simpl. intros. rewrite C; auto with asmgen. Simpl. + congruence. +*) +- (* Mreturn *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. simpl in H6; monadInv H6. + assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + +- (* internal function *) + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. + unfold store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i + Pget GPR8 RA ::i + storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. + set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. + set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). + exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } + rewrite H3. rewrite H4. + (* change (rs' GPR8) with (rs0 RA). *) + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. + congruence. congruence. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: + exec_straight tge tf + tf.(fn_code) rs0 m' + x0 rs3 m3'). + { change (fn_code tf) with tfbody; unfold tfbody. + apply exec_straight_step with rs2 m2'. + unfold exec_instr. rewrite C. fold sp. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. + reflexivity. + eapply exec_straight_trans. + - eexact U'. + - eexact U. } + exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3 m3'); split. + eapply exec_straight_steps_1; eauto. omega. constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite V. + assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H6; 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 V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. + +- (* external function *) + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. apply agree_set_pair; auto. + +- (* return *) + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, Mach.initial_state prog st1 -> + exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. 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 := + (fun a b c => False). + +Axiom transf_program_correct: + forward_simulation (Machblock.semantics return_address_offset prog) (Asmblock.semantics tprog). + +(* +Theorem transf_program_correct: + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. *) + +End PRESERVATION. -- cgit From bcc47e526b2b6e5fd3c8e2b68cadb70628075ea0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 30 Aug 2018 16:11:18 +0200 Subject: Example of Program use... --- mppa_k1c/Asmblock.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index c83867f1..4d7ff03c 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -510,6 +510,20 @@ Qed. (** * Utility for Asmblockgen *) +Program Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} + end. +Obligation 1. + intros. split. left; discriminate. discriminate. +Qed. +Obligation 2. + intros. split. right; discriminate. + unfold builtin_alone. intros. auto. +Qed. + +(* Example bblock_single_basic_correct : forall i, wf_bblock nil (i::nil) None. Proof. intros. split. left; discriminate. discriminate. @@ -521,6 +535,7 @@ Proof. unfold builtin_alone. intros. auto. Qed. + Definition bblock_single_inst (i: instruction) := match i with | PBasic b => {| header:=nil; body:=(b::nil); exit:=None; @@ -528,6 +543,7 @@ Definition bblock_single_inst (i: instruction) := | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl); correct:=bblock_single_control_correct ctl |} end. +*) (** * Operational semantics *) -- cgit From d1c08acee2c3aca35a2dd31b69f7cde852069f6c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 31 Aug 2018 11:09:12 +0200 Subject: Asmblockgen: Added Pnop and Program Definitions --- mppa_k1c/Asmblock.v | 45 +++++++-------------------------------------- mppa_k1c/Asmblockgen.v | 33 +++++++++++++++------------------ 2 files changed, 22 insertions(+), 56 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 4d7ff03c..253ae05d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -387,6 +387,7 @@ Inductive basic : Type := | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) | Pget (rd: ireg) (rs: breg) (**r get system register *) | Pset (rd: breg) (rs: ireg) (**r set system register *) + | Pnop (**r virtual instruction that does nothing *) . Coercion PLoad: ld_instruction >-> basic. @@ -424,6 +425,9 @@ Record bblock := mk_bblock { correct: wf_bblock header body exit }. +Ltac bblock_auto_correct := (split; try discriminate; try (left; discriminate); try (right; discriminate)). +Local Obligation Tactic := bblock_auto_correct. + (* FIXME: redundant with definition in Machblock *) Definition length_opt {A} (o: option A) : nat := match o with @@ -498,16 +502,6 @@ Fixpoint extract_ctl (c: code) := | PControl i :: _ => None (* if the first found control instruction isn't the last *) end. -Example wf_bblock_exbasic_none : forall hd i c0 ctl, wf_bblock hd ((i :: c0) ++ extract_basic ctl) None. -Proof. - intros. split. left; discriminate. discriminate. -Qed. - -Example wf_bblock_exbasic_cfi : forall hd c ctl i, wf_bblock hd (c ++ extract_basic ctl) (Some (PCtlFlow i)). -Proof. - intros. split. right; discriminate. discriminate. -Qed. - (** * Utility for Asmblockgen *) Program Definition bblock_single_inst (i: instruction) := @@ -515,36 +509,10 @@ Program Definition bblock_single_inst (i: instruction) := | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} end. -Obligation 1. - intros. split. left; discriminate. discriminate. -Qed. -Obligation 2. - intros. split. right; discriminate. - unfold builtin_alone. intros. auto. -Qed. - -(* -Example bblock_single_basic_correct : forall i, wf_bblock nil (i::nil) None. -Proof. - intros. split. left; discriminate. discriminate. -Qed. - -Example bblock_single_control_correct : forall i, wf_bblock nil nil (Some i). -Proof. - intros. split. right; discriminate. - unfold builtin_alone. intros. auto. +Next Obligation. + bblock_auto_correct. Qed. - -Definition bblock_single_inst (i: instruction) := - match i with - | PBasic b => {| header:=nil; body:=(b::nil); exit:=None; - correct:=bblock_single_basic_correct b |} - | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl); - correct:=bblock_single_control_correct ctl |} - end. -*) - (** * Operational semantics *) (** The semantics operates over a single mapping from registers @@ -926,6 +894,7 @@ Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset | RA => Next (rs#ra <- (rs#rd)) m | _ => Stuck end + | Pnop => Next rs m end. Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c55e6d94..f9f38b18 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -838,26 +838,23 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) -Fixpoint gen_bblocks_rec (fuel: nat) (hd: list label) (c: list basic) (ctl: list instruction) := - match fuel with - | O => nil - | (Datatypes.S) n => - match (extract_ctl ctl) with - | None => - match c with - | nil => nil (* empty block should not happen *) - | i::c => {| header := hd; body := (i::c) ++ (extract_basic ctl); exit := None; - correct := wf_bblock_exbasic_none hd i c ctl |} :: nil - end - | Some (PExpand (Pbuiltin ef args res)) => (gen_bblocks_rec n hd c nil) ++ - ((PExpand (Pbuiltin ef args res)) ::b nil) - | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i); - correct := wf_bblock_exbasic_cfi hd c ctl i |} :: nil - end +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. -Definition gen_bblocks := gen_bblocks_rec 42. +(** 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 => gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil + | Some (PExpand (Pbuiltin ef args res)) => (gen_bblock_noctl hd c) :: + ((PExpand (Pbuiltin ef args res)) ::b nil) + | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil + end +. Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := do c <- transl_basic_code' f fb.(Machblock.body) true; -- cgit From 1412a262c0bb95ebc78ac7c4d79e0fa81954c82a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 4 Sep 2018 17:53:21 +0200 Subject: Asmblock -> Asm presque fini.. erreur sur driver/Compiler.v --- mppa_k1c/Asm.v | 1695 +++++++++++------------------------------- mppa_k1c/Asmblock.v | 508 ++++++------- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof.v | 3 +- mppa_k1c/Asmgen.v | 824 +------------------- mppa_k1c/Asmgenproof.v | 1102 +-------------------------- mppa_k1c/Machblockgen.v | 2 +- mppa_k1c/Machblockgenproof.v | 8 +- 8 files changed, 753 insertions(+), 3391 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index df394ecf..d71304fa 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,1244 +1,451 @@ -(* *********************************************************************) -(* *) -(* 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 Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. - -(** * Abstract syntax *) - -(** General Purpose registers. *) - -Inductive gpreg: Type := - | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg - | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg - | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg - | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg - | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg - | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg - | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg - | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg - | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg - | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg - | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg - | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg - | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. - -Definition ireg := gpreg. -Definition freg := gpreg. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -(** We model the following registers of the RISC-V architecture. *) - -Inductive preg: Type := - | IR: gpreg -> preg (**r integer registers *) - | FR: gpreg -> preg (**r float registers *) - | RA: preg (**r return address *) - | PC: preg. (**r program counter *) - -Coercion IR: gpreg >-> preg. -Coercion FR: gpreg >-> preg. - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) - -Notation "'SP'" := GPR12 (only parsing) : asm. -Notation "'FP'" := GPR10 (only parsing) : asm. -Notation "'RTMP'" := GPR31 (only parsing) : asm. - -Inductive btest: Type := - | BTdnez (**r Double Not Equal to Zero *) - | BTdeqz (**r Double Equal to Zero *) - | BTdltz (**r Double Less Than Zero *) - | 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 *) - | BTweqz (**r Word Equal to Zero *) - | BTwltz (**r Word Less Than Zero *) - | BTwgez (**r Word Greater Than or Equal to Zero *) - | BTwlez (**r Word Less Than or Equal to Zero *) - | BTwgtz (**r Word Greater Than Zero *) - . - -Inductive itest: Type := - | ITne (**r Not Equal *) - | ITeq (**r Equal *) - | ITlt (**r Less Than *) - | ITge (**r Greater Than or Equal *) - | ITle (**r Less Than or Equal *) - | ITgt (**r Greater Than *) - | ITneu (**r Unsigned Not Equal *) - | ITequ (**r Unsigned Equal *) - | ITltu (**r Less Than Unsigned *) - | 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 *) - . - -(** Offsets for load and store instructions. An offset is either an - immediate integer or the low part of a symbol. *) - -Inductive offset : Type := - | Ofsimm (ofs: ptrofs) - | Ofslow (id: ident) (ofs: ptrofs). - -(** We model a subset of the K1c instruction set. In particular, we do not - support floats yet. - - Although it is possible to use the 32-bits mode, for now we don't support it. - - We follow a design close to the one used for the Risc-V port: one set of - pseudo-instructions for 32-bit integer arithmetic, with suffix W, another - set for 64-bit integer arithmetic, with suffix L. - - When mapping to actual instructions, the OCaml code in TargetPrinter.ml - throws an error if we are not in 64-bits mode. -*) - -Definition label := positive. - -(** 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 *) -Inductive ex_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 *) -(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Ploadli (rd: ireg) (i: int64) (**r load an immediate int64 *) - | Ploadfi (rd: freg) (f: float) (**r load an immediate float *) - | Ploadsi (rd: freg) (f: float32) (**r load an immediate single *) - | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) - (* Instructions not generated by Asmgen (most likely result of AsmExpand) *) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) -. - -(** The pseudo-instructions are the following: - -- [Plabel]: define a code label at the current program point. - -- [Ploadsymbol]: load the address of a symbol in an integer register. - Expands to the [la] assembler pseudo-instruction, which does the right - thing even if we are in PIC mode. - -- [Ploadli rd ival]: load an immediate 64-bit integer into an integer - register rd. Expands to a load from an address in the constant data section, - using the integer register x31 as temporary: -<< - lui x31, %hi(lbl) - ld rd, %lo(lbl)(x31) -lbl: - .quad ival ->> - -- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval - into a float register rd. - -- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval - into a float register rd. - -- [Pallocframe sz pos]: in the formal semantics, this - pseudo-instruction allocates a memory block with bounds [0] and - [sz], stores the value of the stack pointer at offset [pos] in this - block, and sets the stack pointer to the address of the bottom of - this block. - In the printed ASM assembly code, this allocation is: -<< - mv x30, sp - sub sp, sp, #sz - sw x30, #pos(sp) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. - -- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction - reads the word at [pos] of the block pointed by the stack pointer, - frees this block, and sets the stack pointer to the value read. - In the printed ASM assembly code, this freeing is just an increment of [sp]: -<< - add sp, sp, #sz ->> - Again, our memory model cannot comprehend that this operation - frees (logically) the current stack frame. - -- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table - as follows: -<< - la x31, table - add x31, x31, reg - jr x31 -table: .long table[0], table[1], ... ->> - Note that [reg] contains 4 times the index of the desired table entry. - -- [Pseq rd rs1 rs2]: since unsigned comparisons have particular - semantics for pointers, we cannot encode equality directly using - xor/sub etc, which have only integer semantics. -<< - xor rd, rs1, rs2 - sltiu rd, rd, 1 ->> - The [xor] is omitted if one of [rs1] and [rs2] is [x0]. - -- [Psne rd rs1 rs2]: similarly for unsigned inequality. -<< - xor rd, rs1, rs2 - sltu rd, x0, rd ->> -*) - -(** Control Flow instructions *) -Inductive cf_instruction : Type := - | 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 *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pj_l (l: label) (**r jump to label *) - (* Conditional branches *) - | 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 *) -. - -(** Loads **) -Inductive ld_instruction : Type := - | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) -. - -(** Stores **) -Inductive st_instruction : Type := - | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) - | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) -. - -(** Arithmetic instructions **) -Inductive arith_name_r : Type := - | Pcvtw2l (**r Convert Word to Long *) -. - -Inductive arith_name_rr : Type := - | Pmv (**r register move *) - | Pnegw (**r negate word *) - | Pnegl (**r negate long *) - | Pfnegd (**r float negate double *) - | Pcvtl2w (**r Convert Long to Word *) - | Pmvw2l (**r Move Convert Word to Long *) -. - -Inductive arith_name_ri32 : Type := - | Pmake (**r load immediate *) -. - -Inductive arith_name_ri64 : Type := - | Pmakel (**r load immediate long *) -. - -Inductive arith_name_rrr : Type := - | Pcompw (it: itest) (**r comparison word *) - | Pcompl (it: itest) (**r comparison long *) - - | Paddw (**r add word *) - | Psubw (**r sub word *) - | Pmulw (**r mul word *) - | Pandw (**r and word *) - | Porw (**r or word *) - | Pxorw (**r xor word *) - | Psraw (**r shift right arithmetic word *) - | Psrlw (**r shift right logical word *) - | Psllw (**r shift left logical word *) - - | Paddl (**r add long *) - | Psubl (**r sub long *) - | Pandl (**r and long *) - | Porl (**r or long *) - | Pxorl (**r xor long *) - | Pmull (**r mul long (low part) *) - | Pslll (**r shift left logical long *) - | Psrll (**r shift right logical long *) - | Psral (**r shift right arithmetic long *) -. - -Inductive arith_name_rri32 : Type := - | Pcompiw (it: itest) (**r comparison imm word *) - - | Paddiw (**r add imm word *) - | Pandiw (**r and imm word *) - | Poriw (**r or imm word *) - | Pxoriw (**r xor imm word *) - | Psraiw (**r shift right arithmetic imm word *) - | Psrliw (**r shift right logical imm word *) - | Pslliw (**r shift left logical imm word *) - - | Psllil (**r shift left logical immediate long *) - | Psrlil (**r shift right logical immediate long *) - | Psrail (**r shift right arithmetic immediate long *) -. - -Inductive arith_name_rri64 : Type := - | Pcompil (it: itest) (**r comparison imm long *) - | Paddil (**r add immediate long *) - | Pandil (**r and immediate long *) - | Poril (**r or immediate long *) - | Pxoril (**r xor immediate long *) -. - -Inductive ar_instruction : Type := - | PArithR (i: arith_name_r) (rd: ireg) - | PArithRR (i: arith_name_rr) (rd rs: ireg) - | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) - | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) - | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) - | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) - | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) -. - -Coercion PArithR: arith_name_r >-> Funclass. -Coercion PArithRR: arith_name_rr >-> Funclass. -Coercion PArithRI32: arith_name_ri32 >-> Funclass. -Coercion PArithRI64: arith_name_ri64 >-> Funclass. -Coercion PArithRRR: arith_name_rrr >-> Funclass. -Coercion PArithRRI32: arith_name_rri32 >-> Funclass. -Coercion PArithRRI64: arith_name_rri64 >-> Funclass. - -(*| Pfence (**r fence *) - - (* floating point register move *) - | Pfmv (rd: freg) (rs: freg) (**r move *) - | Pfmvxs (rd: ireg) (rs: freg) (**r move FP single to integer register *) - | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) - -*)(* 32-bit (single-precision) floating point *) - -(*| Pfnegs (rd: freg) (rs: freg) (**r negation *) - | Pfabss (rd: freg) (rs: freg) (**r absolute value *) - - | Pfadds (rd: freg) (rs1 rs2: freg) (**r addition *) - | Pfsubs (rd: freg) (rs1 rs2: freg) (**r subtraction *) - | Pfmuls (rd: freg) (rs1 rs2: freg) (**r multiplication *) - | Pfdivs (rd: freg) (rs1 rs2: freg) (**r division *) - | Pfmins (rd: freg) (rs1 rs2: freg) (**r minimum *) - | Pfmaxs (rd: freg) (rs1 rs2: freg) (**r maximum *) - - | Pfeqs (rd: ireg) (rs1 rs2: freg) (**r compare equal *) - | Pflts (rd: ireg) (rs1 rs2: freg) (**r compare less-than *) - | Pfles (rd: ireg) (rs1 rs2: freg) (**r compare less-than/equal *) - - | Pfsqrts (rd: freg) (rs: freg) (**r square-root *) - - | Pfmadds (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-add *) - | Pfmsubs (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-sub *) - | Pfnmadds (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-add *) - | Pfnmsubs (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-sub *) - - | Pfcvtws (rd: ireg) (rs: freg) (**r float32 -> int32 conversion *) - | Pfcvtwus (rd: ireg) (rs: freg) (**r float32 -> unsigned int32 conversion *) - | Pfcvtsw (rd: freg) (rs: ireg) (**r int32 -> float32 conversion *) - | Pfcvtswu (rd: freg) (rs: ireg) (**r unsigned int32 -> float32 conversion *) - - | Pfcvtls (rd: ireg) (rs: freg) (**r float32 -> int64 conversion *) - | Pfcvtlus (rd: ireg) (rs: freg) (**r float32 -> unsigned int64 conversion *) - | Pfcvtsl (rd: freg) (rs: ireg) (**r int64 -> float32 conversion *) - | Pfcvtslu (rd: freg) (rs: ireg) (**r unsigned int 64-> float32 conversion *) - -*)(* 64-bit (double-precision) floating point *) -(*| Pfld_a (rd: freg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Pfsd_a (rd: freg) (ra: ireg) (ofs: offset) (**r store any64 *) - - | Pfabsd (rd: freg) (rs: freg) (**r absolute value *) - - | Pfaddd (rd: freg) (rs1 rs2: freg) (**r addition *) - | Pfsubd (rd: freg) (rs1 rs2: freg) (**r subtraction *) - | Pfmuld (rd: freg) (rs1 rs2: freg) (**r multiplication *) - | Pfdivd (rd: freg) (rs1 rs2: freg) (**r division *) - | Pfmind (rd: freg) (rs1 rs2: freg) (**r minimum *) - | Pfmaxd (rd: freg) (rs1 rs2: freg) (**r maximum *) - - | Pfeqd (rd: ireg) (rs1 rs2: freg) (**r compare equal *) - | Pfltd (rd: ireg) (rs1 rs2: freg) (**r compare less-than *) - | Pfled (rd: ireg) (rs1 rs2: freg) (**r compare less-than/equal *) - - | Pfsqrtd (rd: freg) (rs: freg) (**r square-root *) - - | Pfmaddd (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-add *) - | Pfmsubd (rd: freg) (rs1 rs2 rs3: freg) (**r fused multiply-sub *) - | Pfnmaddd (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-add *) - | Pfnmsubd (rd: freg) (rs1 rs2 rs3: freg) (**r fused negated multiply-sub *) - - | Pfcvtwd (rd: ireg) (rs: freg) (**r float -> int32 conversion *) - | Pfcvtwud (rd: ireg) (rs: freg) (**r float -> unsigned int32 conversion *) - | Pfcvtdw (rd: freg) (rs: ireg) (**r int32 -> float conversion *) - | Pfcvtdwu (rd: freg) (rs: ireg) (**r unsigned int32 -> float conversion *) - - | Pfcvtld (rd: ireg) (rs: freg) (**r float -> int64 conversion *) - | Pfcvtlud (rd: ireg) (rs: freg) (**r float -> unsigned int64 conversion *) - | Pfcvtdl (rd: freg) (rs: ireg) (**r int64 -> float conversion *) - | Pfcvtdlu (rd: freg) (rs: ireg) (**r unsigned int64 -> float conversion *) - - | Pfcvtds (rd: freg) (rs: freg) (**r float32 -> float *) - | Pfcvtsd (rd: freg) (rs: freg) (**r float -> float32 *) -*) - -Inductive instruction : Type := - | PExpand (i: ex_instruction) - | PControlFlow (i: cf_instruction) - | PLoad (i: ld_instruction) - | PStore (i: st_instruction) - | PArith (i: ar_instruction) -. - -Coercion PExpand: ex_instruction >-> instruction. -Coercion PControlFlow: cf_instruction >-> instruction. -Coercion PLoad: ld_instruction >-> instruction. -Coercion PStore: st_instruction >-> instruction. -Coercion PArith: ar_instruction >-> instruction. - -Definition code := list instruction. -Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. - -(** * Operational semantics *) - -(** The semantics operates over a single mapping from registers - (type [preg]) to values. We maintain - the convention that integer registers are mapped to values of - type [Tint] or [Tlong] (in 64 bit mode), - and float registers to values of type [Tsingle] or [Tfloat]. *) - -Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef unit. - -Definition getw (rs: regset) (r: ireg) : val := - match r with - | _ => rs r - end. - -Definition getl (rs: regset) (r: ireg) : val := - match r with - | _ => rs r - end. - -Notation "a # b" := (a b) (at level 1, only parsing) : asm. -Notation "a ## b" := (getw a b) (at level 1) : asm. -Notation "a ### b" := (getl a b) (at level 1) : asm. -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. - -Open Scope asm. - -(** Undefining some registers *) - -Fixpoint undef_regs (l: list preg) (rs: regset) : regset := - match l with - | nil => rs - | r :: l' => undef_regs l' (rs#r <- Vundef) - end. - -(** Assigning a register pair *) - -Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := - match p with - | One r => rs#r <- v - | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) - end. - -(** Assigning multiple registers *) - -Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := - match rl, vl with - | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) - | _, _ => rs - end. - -(** Assigning the result of a builtin *) - -Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := - match res with - | BR r => rs#r <- v - | BR_none => rs - | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) - end. - -Section RELSEM. - -(** Looking up instructions in a code sequence by position. *) - -Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := - match c with - | nil => None - | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il - end. - -(** Position corresponding to a label *) - -Definition is_label (lbl: label) (instr: instruction) : bool := - match instr with - | Plabel lbl' => if peq lbl lbl' then true else false - | _ => false - end. - -Lemma is_label_correct: - forall lbl instr, - if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. -Proof. - intros. destruct instr; simpl; try discriminate. - destruct i; simpl; try discriminate. - case (peq lbl lbl0); intro; congruence. -Qed. - -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' - end. - -Variable ge: genv. - -(** The two functions below axiomatize how the linker processes - symbolic references [symbol + offset)] and splits their - actual values into a 20-bit high part [%hi(symbol + offset)] and - a 12-bit low part [%lo(symbol + offset)]. *) - -Parameter low_half: genv -> ident -> ptrofs -> ptrofs. -Parameter high_half: genv -> ident -> ptrofs -> val. - -(** The fundamental property of these operations is that, when applied - to the address of a symbol, their results can be recombined by - addition, rebuilding the original address. *) - -Axiom low_high_half: - forall id ofs, - Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. - -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [Next rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Stuck] if the processor is stuck. *) - -Inductive outcome: Type := - | Next: regset -> mem -> outcome - | Stuck: outcome. - -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). *) - -Definition nextinstr (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). - -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 (fn_code f) with - | None => Stuck - | Some pos => - match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m - | _ => Stuck - end - end. - -(** Auxiliaries for memory accesses *) - -Definition eval_offset (ofs: offset) : ptrofs := - match ofs with - | Ofsimm n => n - | Ofslow id delta => low_half ge id delta - end. - -Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) - (d: preg) (a: ireg) (ofs: offset) := - match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with - | None => Stuck - | Some v => Next (nextinstr (rs#d <- v)) m - end. - -Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) - (s: preg) (a: ireg) (ofs: offset) := - match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with - | None => Stuck - | Some m' => Next (nextinstr rs) m' - end. - -(** Evaluating a branch *) - -Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := - match res with - | Some true => goto_label f l rs m - | Some false => Next (nextinstr rs) m - | None => Stuck - end. - -Inductive signedness: Type := Signed | Unsigned. - -Inductive intsize: Type := Int | Long. - -Definition itest_for_cmp (c: comparison) (s: signedness) := - match c, s with - | Cne, Signed => ITne - | Ceq, Signed => ITeq - | Clt, Signed => ITlt - | Cge, Signed => ITge - | Cle, Signed => ITle - | Cgt, Signed => ITgt - | Cne, Unsigned => ITneu - | Ceq, Unsigned => ITequ - | Clt, Unsigned => ITltu - | Cge, Unsigned => ITgeu - | Cle, Unsigned => ITleu - | Cgt, Unsigned => ITgtu - end. - -(* CoMPare Signed Words to Zero *) -Definition btest_for_cmpswz (c: comparison) := - match c with - | Cne => BTwnez - | Ceq => BTweqz - | Clt => BTwltz - | Cge => BTwgez - | Cle => BTwlez - | Cgt => BTwgtz - end. - -(* CoMPare Signed Doubles to Zero *) -Definition btest_for_cmpsdz (c: comparison) := - match c with - | Cne => BTdnez - | Ceq => BTdeqz - | Clt => BTdltz - | Cge => BTdgez - | Cle => BTdlez - | Cgt => BTdgtz - end. - -Definition cmp_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTwltz => (Some Clt, Int) - | BTwgez => (Some Cge, Int) - | BTwlez => (Some Cle, Int) - | BTwgtz => (Some Cgt, Int) - - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | BTdltz => (Some Clt, Long) - | BTdgez => (Some Cge, Long) - | BTdlez => (Some Cle, Long) - | BTdgtz => (Some Cgt, Long) - end. - -Definition cmpu_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | _ => (None, Int) - end. - -(** Comparing integers *) -Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := - match t with - | ITne => Val.cmp Cne v1 v2 - | ITeq => Val.cmp Ceq v1 v2 - | ITlt => Val.cmp Clt v1 v2 - | ITge => Val.cmp Cge v1 v2 - | ITle => Val.cmp Cle v1 v2 - | ITgt => Val.cmp Cgt v1 v2 - | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2 - | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 - | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2 - | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2 - | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2 - | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 - | ITall - | ITnall - | ITany - | ITnone => Vundef - end. - -Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := - let res := match t with - | ITne => Val.cmpl Cne v1 v2 - | ITeq => Val.cmpl Ceq v1 v2 - | ITlt => Val.cmpl Clt v1 v2 - | ITge => Val.cmpl Cge v1 v2 - | ITle => Val.cmpl Cle v1 v2 - | ITgt => Val.cmpl Cgt v1 v2 - | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 - | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 - | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2 - | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2 - | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2 - | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2 - | ITall - | ITnall - | ITany - | ITnone => Some Vundef - end in - match res with - | Some v => v - | None => Vundef - end - . - -(** Execution of a single instruction [i] in initial state [rs] and - [m]. Return updated state. For instructions that correspond to - 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. - - 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 exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := -(** Get/Set system registers *) - match i with - | Pget rd ra => - match ra with - | RA => Next (nextinstr (rs#rd <- (rs#ra))) m - | _ => Stuck - end - | Pset ra rd => - match ra with - | RA => Next (nextinstr (rs#ra <- (rs#rd))) m - | _ => Stuck - end - -(** Branch Control Unit instructions *) - | Pret => - Next (rs#PC <- (rs#RA)) m - | Pcall s => - Next (rs#RA <- (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pgoto s => - Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pj_l l => - goto_label f l rs m - | Pcb bt r l => - match cmp_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - | Pcbu bt r l => - match cmpu_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs##r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs###r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - -(** Arithmetic Instructions *) - | PArithR n d => - match n with - | Pcvtw2l => Next (nextinstr (rs#d <- (Val.longofint rs#d))) m - end - - | PArithRR n d s => - match n with - | Pmv => Next (nextinstr (rs#d <- (rs#s))) m - | Pnegw => Next (nextinstr (rs#d <- (Val.neg rs###s))) m - | Pnegl => Next (nextinstr (rs#d <- (Val.negl rs###s))) m - | Pfnegd => Next (nextinstr (rs#d <- (Val.negf rs#s))) m - | Pcvtl2w => Next (nextinstr (rs#d <- (Val.loword rs###s))) m - | Pmvw2l => Next (nextinstr (rs#d <- (Val.longofint rs#s))) m - end - - | PArithRI32 n d i => - match n with - | Pmake => Next (nextinstr (rs#d <- (Vint i))) m - end - - | PArithRI64 n d i => - match n with - | Pmakel => Next (nextinstr (rs#d <- (Vlong i))) m - end - - | PArithRRR n d s1 s2 => - match n with - | Pcompw c => Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m - | Pcompl c => Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m - | Paddw => Next (nextinstr (rs#d <- (Val.add rs##s1 rs##s2))) m - | Psubw => Next (nextinstr (rs#d <- (Val.sub rs##s1 rs##s2))) m - | Pmulw => Next (nextinstr (rs#d <- (Val.mul rs##s1 rs##s2))) m - | Pandw => Next (nextinstr (rs#d <- (Val.and rs##s1 rs##s2))) m - | Porw => Next (nextinstr (rs#d <- (Val.or rs##s1 rs##s2))) m - | Pxorw => Next (nextinstr (rs#d <- (Val.xor rs##s1 rs##s2))) m - | Psrlw => Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m - | Psraw => Next (nextinstr (rs#d <- (Val.shr rs##s1 rs##s2))) m - | Psllw => Next (nextinstr (rs#d <- (Val.shl rs##s1 rs##s2))) m - - | Paddl => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m - | Psubl => Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m - | Pandl => Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m - | Porl => Next (nextinstr (rs#d <- (Val.orl rs###s1 rs###s2))) m - | Pxorl => Next (nextinstr (rs#d <- (Val.xorl rs###s1 rs###s2))) m - | Pmull => Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m - | Pslll => Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m - | Psrll => Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m - | Psral => Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m - end - - | PArithRRI32 n d s i => - match n with - | Pcompiw c => Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m - | Paddiw => Next (nextinstr (rs#d <- (Val.add rs##s (Vint i)))) m - | Pandiw => Next (nextinstr (rs#d <- (Val.and rs##s (Vint i)))) m - | Poriw => Next (nextinstr (rs#d <- (Val.or rs##s (Vint i)))) m - | Pxoriw => Next (nextinstr (rs#d <- (Val.xor rs##s (Vint i)))) m - | Psraiw => Next (nextinstr (rs#d <- (Val.shr rs##s (Vint i)))) m - | Psrliw => Next (nextinstr (rs#d <- (Val.shru rs##s (Vint i)))) m - | Pslliw => Next (nextinstr (rs#d <- (Val.shl rs##s (Vint i)))) m - - | Psllil => Next (nextinstr (rs#d <- (Val.shll rs###s (Vint i)))) m - | Psrlil => Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m - | Psrail => Next (nextinstr (rs#d <- (Val.shrl rs###s (Vint i)))) m - end - - | PArithRRI64 n d s i => - match n with - | Pcompil c => Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m - | Paddil => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m - | Pandil => Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m - | Poril => Next (nextinstr (rs#d <- (Val.orl rs###s (Vlong i)))) m - | Pxoril => Next (nextinstr (rs#d <- (Val.xorl rs###s (Vlong i)))) m - end - -(** Loads and stores *) - | Plb d a ofs => - exec_load Mint8signed rs m d a ofs - | Plbu d a ofs => - exec_load Mint8unsigned rs m d a ofs - | Plh d a ofs => - exec_load Mint16signed rs m d a ofs - | Plhu d a ofs => - exec_load Mint16unsigned rs m d a ofs - | Plw d a ofs => - exec_load Mint32 rs m d a ofs - | Plw_a d a ofs => - exec_load Many32 rs m d a ofs - | Pld d a ofs => - exec_load Mint64 rs m d a ofs - | Pld_a d a ofs => - exec_load Many64 rs m d a ofs - | Psb s a ofs => - exec_store Mint8unsigned rs m s a ofs - | Psh s a ofs => - exec_store Mint16unsigned rs m s a ofs - | Psw s a ofs => - exec_store Mint32 rs m s a ofs - | Psw_a s a ofs => - exec_store Many32 rs m s a ofs - | Psd s a ofs => - exec_store Mint64 rs m s a ofs - | Psd_a s a ofs => - exec_store Many64 rs m s a ofs - -(** Floating point register move *) -(*| Pfmv d s => - Next (nextinstr (rs#d <- (rs#s))) m - -(** 32-bit (single-precision) floating point *) -*)| Pfls d a ofs => - exec_load Mfloat32 rs m d a ofs - | Pfss s a ofs => - exec_store Mfloat32 rs m s a ofs - -(*| Pfnegs d s => - Next (nextinstr (rs#d <- (Val.negfs rs#s))) m - | Pfabss d s => - Next (nextinstr (rs#d <- (Val.absfs rs#s))) m - - | Pfadds d s1 s2 => - Next (nextinstr (rs#d <- (Val.addfs rs#s1 rs#s2))) m - | Pfsubs d s1 s2 => - Next (nextinstr (rs#d <- (Val.subfs rs#s1 rs#s2))) m - | Pfmuls d s1 s2 => - Next (nextinstr (rs#d <- (Val.mulfs rs#s1 rs#s2))) m - | Pfdivs d s1 s2 => - Next (nextinstr (rs#d <- (Val.divfs rs#s1 rs#s2))) m - | Pfeqs d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpfs Ceq rs#s1 rs#s2))) m - | Pflts d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpfs Clt rs#s1 rs#s2))) m - | Pfles d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpfs Cle rs#s1 rs#s2))) m - - | Pfcvtws d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.intofsingle rs#s)))) m - | Pfcvtwus d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.intuofsingle rs#s)))) m - | Pfcvtsw d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofint rs##s)))) m - | Pfcvtswu d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofintu rs##s)))) m - - | Pfcvtls d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.longofsingle rs#s)))) m - | Pfcvtlus d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.longuofsingle rs#s)))) m - | Pfcvtsl d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflong rs###s)))) m - | Pfcvtslu d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflongu rs###s)))) m - -(** 64-bit (double-precision) floating point *) -*)| Pfld d a ofs => - exec_load Mfloat64 rs m d a ofs -(*| Pfld_a d a ofs => - exec_load Many64 rs m d a ofs -*)| Pfsd s a ofs => - exec_store Mfloat64 rs m s a ofs -(*| Pfsd_a s a ofs => - exec_store Many64 rs m s a ofs - - | Pfabsd d s => - Next (nextinstr (rs#d <- (Val.absf rs#s))) m - - | Pfaddd d s1 s2 => - Next (nextinstr (rs#d <- (Val.addf rs#s1 rs#s2))) m - | Pfsubd d s1 s2 => - Next (nextinstr (rs#d <- (Val.subf rs#s1 rs#s2))) m - | Pfmuld d s1 s2 => - Next (nextinstr (rs#d <- (Val.mulf rs#s1 rs#s2))) m - | Pfdivd d s1 s2 => - Next (nextinstr (rs#d <- (Val.divf rs#s1 rs#s2))) m - | Pfeqd d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpf Ceq rs#s1 rs#s2))) m - | Pfltd d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpf Clt rs#s1 rs#s2))) m - | Pfled d s1 s2 => - Next (nextinstr (rs#d <- (Val.cmpf Cle rs#s1 rs#s2))) m - - | Pfcvtwd d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.intoffloat rs#s)))) m - | Pfcvtwud d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.intuoffloat rs#s)))) m - | Pfcvtdw d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofint rs##s)))) m - | Pfcvtdwu d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofintu rs##s)))) m - - | Pfcvtld d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.longoffloat rs#s)))) m - | Pfcvtlud d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.longuoffloat rs#s)))) m - | Pfcvtdl d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflong rs###s)))) m - | Pfcvtdlu d s => - Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflongu rs###s)))) m - - | Pfcvtds d s => - Next (nextinstr (rs#d <- (Val.floatofsingle rs#s))) m - | Pfcvtsd d s => - Next (nextinstr (rs#d <- (Val.singleoffloat rs#s))) m - -(** Pseudo-instructions *) -*)| Pallocframe sz pos => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with - | None => Stuck - | Some m2 => Next (nextinstr (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2 - end - | Pfreeframe sz pos => - match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with - | None => Stuck - | Some v => - match rs SP with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => Stuck - | Some m' => Next (nextinstr (rs#SP <- v #GPR31 <- Vundef)) m' - end - | _ => Stuck - end - end - | Plabel lbl => - Next (nextinstr rs) m - | Ploadsymbol rd s ofs => - Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m -(*| Ploadsymbol_high rd s ofs => - Next (nextinstr (rs#rd <- (high_half ge s ofs))) m - | Ploadli rd i => - Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m - | Ploadfi rd f => - Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vfloat f))) m - | Ploadsi rd f => - Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vsingle f))) m - | Pbtbl r tbl => - match rs r with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => Stuck - | Some lbl => goto_label f lbl (rs#GPR5 <- Vundef #GPR31 <- Vundef) m - end - | _ => Stuck - end -*)| Pbuiltin ef args res => - Stuck (**r treated specially below *) - - (** The following instructions and directives are not generated directly by Asmgen, - so we do not model them. *) - | Pclzll _ _ - | Pstsud _ _ _ - => Stuck - end. - -(** Translation of the LTL/Linear/Mach view of machine registers to - the RISC-V view. Note that no LTL register maps to [X31]. This - register is reserved as temporary, to be used by the generated RV32G - code. *) - - (* FIXME - R31 is not there *) -Definition preg_of (r: mreg) : preg := - match r with - | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 - | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) - | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 - | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 - | R30 => GPR30 | R32 => GPR32 | R33 => GPR33 | R34 => GPR34 - | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 - | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 - | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 - | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 - | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 - | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 - end. - -(** Extract the values of the arguments of an external call. - We exploit the calling conventions from module [Conventions], except that - we use RISC-V registers instead of locations. *) - -Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := - | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (preg_of r)) - | extcall_arg_stack: forall ofs ty bofs v, - bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> - Mem.loadv (chunk_of_type ty) m - (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> - extcall_arg rs m (S Outgoing ofs ty) v. - -Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := - | extcall_arg_one: forall l v, - extcall_arg rs m l v -> - extcall_arg_pair rs m (One l) v - | extcall_arg_twolong: forall hi lo vhi vlo, - extcall_arg rs m hi vhi -> - extcall_arg rs m lo vlo -> - extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. - -Definition loc_external_result (sg: signature) : rpair preg := - map_rpair preg_of (loc_result sg). - -(** Execution of the instruction at [rs PC]. *) - -Inductive state: Type := - | State: regset -> mem -> state. - -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: - forall b ofs f i rs m rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> - exec_instr f i rs m = Next rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (A:=instruction) (Pbuiltin ef args res) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = nextinstr - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <- Vundef))) -> - step (State rs m) t (State rs' m') - | exec_step_external: - forall b ef args res rs m t rs' m', - rs PC = Vptr b Ptrofs.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - external_call ef ge args m t res m' -> - extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> - step (State rs m) t (State rs' m'). - -End RELSEM. - -(** Execution of whole programs. *) - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall m0, - let ge := Genv.globalenv p in - let rs0 := - (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # SP <- Vnullptr - # RA <- Vnullptr in - Genv.init_mem p = Some m0 -> - initial_state p (State rs0 m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r, - rs PC = Vnullptr -> - rs GPR0 = Vint r -> - final_state (State rs m) r. - -Definition semantics (p: program) := - Semantics step (initial_state p) final_state (Genv.globalenv p). - -(** Determinacy of the [Asm] semantics. *) - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. - split. constructor. auto. - discriminate. - discriminate. - assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H11. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. - -(** Classification functions for processor registers (used in Asmgenproof). *) - -Definition data_preg (r: preg) : bool := - match r with - | RA => false - | IR GPR31 => false - | IR GPR8 => false - | IR _ => true - | FR _ => true - | PC => false - end. +(* *********************************************************************) +(* *) +(* 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 Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmblock. +Require Import Linking. +Require Import Errors. + +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) *) + | 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 *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | 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 *) + + (** Loads **) + | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) + | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) + | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) + | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *) + | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) + | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) + | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) + | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) + | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) + | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) + | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) + + (** Arith R *) + | Pcvtw2l (rd: ireg) (**r Convert Word to Long *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Pmvw2l (rd rs: ireg) (**r Move Convert Word to Long *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + + | 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 *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor 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 *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | 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 *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + . + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmblock.Pret => Pret + | PCtlFlow (Asmblock.Pcall l) => Pcall l + | PCtlFlow (Asmblock.Pgoto l) => Pgoto l + | PCtlFlow (Asmblock.Pj_l l) => Pj_l l + | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmblock.Pcbu bt r l) => Pcbu bt r l + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmblock.Pget rd rs => Pget rd rs + | Asmblock.Pset rd rs => Pset rd rs + | Asmblock.Pnop => Pnop + | Asmblock.Pallocframe sz pos => Pallocframe sz pos + | Asmblock.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR Asmblock.Pcvtw2l r => Pcvtw2l r + | PArithR (Asmblock.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmblock.Pmv rd rs => Pmv rd rs + | PArithRR Asmblock.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmblock.Pnegl rd rs => Pfnegd rd rs + | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmblock.Pmvw2l rd rs => Pmvw2l rd rs + | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs + + (* RI32 *) + | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmblock.Pmakel rd imm => Pmakel rd imm + + (* RRR *) + | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR Asmblock.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmblock.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmblock.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmblock.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR Asmblock.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR Asmblock.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmblock.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmblock.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmblock.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmblock.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmblock.Psral rd rs1 rs2 => Psral rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmblock.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmblock.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmblock.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmblock.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 Asmblock.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmblock.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmblock.Pxoril rd rs imm => Pxoril rd rs imm + + (** Load *) + | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs + | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra ofs + | PLoadRRO Asmblock.Plh rd ra ofs => Plh rd ra ofs + | PLoadRRO Asmblock.Plhu rd ra ofs => Plhu rd ra ofs + | PLoadRRO Asmblock.Plw rd ra ofs => Plw rd ra ofs + | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra ofs + | PLoadRRO Asmblock.Pld rd ra ofs => Pld rd ra ofs + | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra ofs + | PLoadRRO Asmblock.Pfls rd ra ofs => Pfls rd ra ofs + | PLoadRRO Asmblock.Pfld rd ra ofs => Pfld rd ra ofs + + (** Store *) + | PStoreRRO Asmblock.Psb rd ra ofs => Psb rd ra ofs + | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra ofs + | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra ofs + | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra ofs + | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra ofs + | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra ofs + | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra ofs + | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfss rd ra 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) ++ unfold_body (body b) ++ unfold_exit (exit b). + +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) := Asmblock.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) : Asmblock.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmblock.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmblock.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 Asmblock.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmblock.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) := Asmblock.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: Asmblock.function) : function := + {| fn_sig := Asmblock.fn_sig f; fn_blocks := Asmblock.fn_blocks f; + fn_code := unfold (Asmblock.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 (f: Asmblock.fundef) : fundef := + match f with + | Internal f => Internal (transf_function f) + | External ef => External ef + end. + +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 (p: Asmblock.program) : program := + {| prog_defs := transf_prog_defs (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +Definition match_prog (p: Asmblock.program) (tp: program) := (p = program_proj tp). + +Lemma asmblock_program_equals: forall (p1 p2: Asmblock.program), + 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_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros p tp H. unfold match_prog. + unfold transf_program in H. + destruct tp as [tdefs tpub tmain]. inv H. + unfold program_proj. simpl. apply asmblock_program_equals; simpl; auto. + apply transf_prog_proj. +Qed. + +Section PRESERVATION. + +Variable prog: Asmblock.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. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (semantics tprog). +Proof. + inversion TRANSF. (* inv H0. *) + eapply forward_simulation_step with (match_states := match_states). + all: try (simpl; congruence). + - simpl. intros s1 H1. exists s1. split; auto. congruence. + - simpl. intros s1 t s1' H1 s2 H2. exists s1'. split. + + congruence. + + unfold match_states. auto. +Qed. + +End PRESERVATION. \ No newline at end of file diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 253ae05d..58cc0f2c 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1161,253 +1161,263 @@ Definition semantics (p: program) := Axiom semantics_determinate: forall p, determinate (semantics p). -(** Determinacy of the [Asm] semantics. *) - -(* TODO. - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. - split. constructor. auto. - discriminate. - discriminate. - assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H11. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. -*) - - -(* - -(** * Instruction dependencies, definition of a bundle - -NOTE: this would be better to do this in an other file, e.g. Asmbundle ? - -*) - -(** NOTE: in all of these dependencies definitions, we do *not* consider PC. - PC dependencies are fullfilled by the above separation in bblocks - *) - -(* (writereg i rd) holds if an instruction writes to a single register rd *) -Inductive writereg: instruction -> preg -> Prop := - | writereg_set: forall rd rs, writereg (Pset rd rs) rd - | writereg_get: forall rd rs, writereg (Pget rd rs) rd - | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd - | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd - | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd - | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd - | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd - | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd - | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd - | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd - . - -(* (nowrite i) holds if an instruction doesn't write to any register *) -Inductive nowrite: instruction -> Prop := - | nowrite_ret: nowrite Pret - | nowrite_call: forall l, nowrite (Pcall l) - | nowrite_goto: forall l, nowrite (Pgoto l) - | nowrite_jl: forall l, nowrite (Pj_l l) - | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) - | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) - | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) - | nowrite_label: forall l, nowrite (Plabel l) - . - -(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) -Inductive readregs: instruction -> list preg -> Prop := - | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) - | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) - | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) - | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) - | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) - | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) - | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) - | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) - | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) - | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) - . - -(* (noread i) holds if an instruction doesn't read any register *) -Inductive noread: instruction -> Prop := - | noread_ret: noread Pret - | noread_call: forall l, noread (Pcall l) - | noread_goto: forall l, noread (Pgoto l) - | noread_jl: forall l, noread (Pj_l l) - | noread_arith_r: forall i rd, noread (PArithR i rd) - | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) - | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) - | noread_label: forall l, noread (Plabel l) - . - -(* (wawfree i i') holds if i::i' has no WAW dependency *) -Inductive wawfree: instruction -> instruction -> Prop := - | wawfree_write: forall i rs i' rs', - writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' - | wawfree_free1: forall i i', - nowrite i -> wawfree i i' - | wawfree_free2: forall i i', - nowrite i' -> wawfree i i' - . - -(* (rawfree i i') holds if i::i' has no RAW dependency *) -Inductive rawfree: instruction -> instruction -> Prop := - | rawfree_single: forall i rd i' rs, - writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' - | rawfree_double: forall i rd i' rs rs', - writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' - | rawfree_free1: forall i i', - nowrite i -> rawfree i i' - | rawfree_free2: forall i i', - noread i' -> rawfree i i' - . - -(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) -Inductive depfree: instruction -> instruction -> Prop := - | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. - -(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) -Inductive depfreelist: instruction -> list instruction -> Prop := - | depfreelist_nil: forall i, - depfreelist i nil - | depfreelist_cons: forall i i' l, - depfreelist i l -> depfree i i' -> depfreelist i (i'::l) - . - -(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) -Inductive depfreeall: list instruction -> Prop := - | depfreeall_nil: - depfreeall nil - | depfreeall_cons: forall i l, - depfreeall l -> depfreelist i l -> depfreeall (i::l) - . - -(** NOTE: we do not verify the resource constraints of the bundles, - since not meeting them causes a failure when invoking the assembler *) - -(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) -Inductive wf_bundle: bblock -> Prop := - | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. - -Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. - -Record bundle := mk_bundle { - bd_block: bblock; - bd_correct: wf_bundle bd_block -}. - -Definition bundles := list bundle. - -Definition unbundlize (lb: list bundle) := map bd_block lb. -Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). - -Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. -Proof. - intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. -Qed. - -(** Some theorems on bundles construction *) -Lemma bundle_empty_correct: wf_bundle empty_bblock. -Proof. - constructor. auto. -Qed. - -Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. - -(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) - -Definition single_inst_block (i: instruction) := acc_block i empty_bblock. - -Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). -Proof. - intros i. unfold single_inst_block. unfold acc_block. destruct i. - all: simpl; constructor; simpl; auto. -Qed. - -Definition bundlize_inst (i: instruction) := - {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. - -Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. -Proof. - induction c as [|i c]; simpl; auto. - rewrite IHc. destruct i; simpl; auto. -Qed. - -Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). - -Fixpoint bundlize (lb: list bblock) := - match lb with - | nil => nil - | b :: lb => split_bblock b ++ bundlize lb - end. - -Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. -Proof. - intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. -Qed. - -Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. -Proof. - induction lb as [|b lb]; simpl; auto. - rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. -Qed. - -Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. -Proof. - intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. -Qed. - -Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. -Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. +Definition data_preg (r: preg) : bool := + match r with + | RA => false + | IR GPR31 => false + | IR GPR8 => false + | IR _ => true + | FR _ => true + | PC => false + end. + +(** Determinacy of the [Asm] semantics. *) + +(* TODO. + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + split. constructor. auto. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. +*) + + +(* + +(** * Instruction dependencies, definition of a bundle + +NOTE: this would be better to do this in an other file, e.g. Asmbundle ? + +*) + +(** NOTE: in all of these dependencies definitions, we do *not* consider PC. + PC dependencies are fullfilled by the above separation in bblocks + *) + +(* (writereg i rd) holds if an instruction writes to a single register rd *) +Inductive writereg: instruction -> preg -> Prop := + | writereg_set: forall rd rs, writereg (Pset rd rs) rd + | writereg_get: forall rd rs, writereg (Pget rd rs) rd + | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd + | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd + | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd + | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd + | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd + | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd + | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd + | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd + . + +(* (nowrite i) holds if an instruction doesn't write to any register *) +Inductive nowrite: instruction -> Prop := + | nowrite_ret: nowrite Pret + | nowrite_call: forall l, nowrite (Pcall l) + | nowrite_goto: forall l, nowrite (Pgoto l) + | nowrite_jl: forall l, nowrite (Pj_l l) + | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) + | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) + | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) + | nowrite_label: forall l, nowrite (Plabel l) + . + +(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) +Inductive readregs: instruction -> list preg -> Prop := + | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) + | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) + | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) + | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) + | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) + | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) + | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) + | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) + | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) + | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) + . + +(* (noread i) holds if an instruction doesn't read any register *) +Inductive noread: instruction -> Prop := + | noread_ret: noread Pret + | noread_call: forall l, noread (Pcall l) + | noread_goto: forall l, noread (Pgoto l) + | noread_jl: forall l, noread (Pj_l l) + | noread_arith_r: forall i rd, noread (PArithR i rd) + | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) + | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) + | noread_label: forall l, noread (Plabel l) + . + +(* (wawfree i i') holds if i::i' has no WAW dependency *) +Inductive wawfree: instruction -> instruction -> Prop := + | wawfree_write: forall i rs i' rs', + writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' + | wawfree_free1: forall i i', + nowrite i -> wawfree i i' + | wawfree_free2: forall i i', + nowrite i' -> wawfree i i' + . + +(* (rawfree i i') holds if i::i' has no RAW dependency *) +Inductive rawfree: instruction -> instruction -> Prop := + | rawfree_single: forall i rd i' rs, + writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' + | rawfree_double: forall i rd i' rs rs', + writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' + | rawfree_free1: forall i i', + nowrite i -> rawfree i i' + | rawfree_free2: forall i i', + noread i' -> rawfree i i' + . + +(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) +Inductive depfree: instruction -> instruction -> Prop := + | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. + +(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) +Inductive depfreelist: instruction -> list instruction -> Prop := + | depfreelist_nil: forall i, + depfreelist i nil + | depfreelist_cons: forall i i' l, + depfreelist i l -> depfree i i' -> depfreelist i (i'::l) + . + +(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) +Inductive depfreeall: list instruction -> Prop := + | depfreeall_nil: + depfreeall nil + | depfreeall_cons: forall i l, + depfreeall l -> depfreelist i l -> depfreeall (i::l) + . + +(** NOTE: we do not verify the resource constraints of the bundles, + since not meeting them causes a failure when invoking the assembler *) + +(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) +Inductive wf_bundle: bblock -> Prop := + | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. + +Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. + +Record bundle := mk_bundle { + bd_block: bblock; + bd_correct: wf_bundle bd_block +}. + +Definition bundles := list bundle. + +Definition unbundlize (lb: list bundle) := map bd_block lb. +Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). + +Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. +Proof. + intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. +Qed. + +(** Some theorems on bundles construction *) +Lemma bundle_empty_correct: wf_bundle empty_bblock. +Proof. + constructor. auto. +Qed. + +Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. + +(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) + +Definition single_inst_block (i: instruction) := acc_block i empty_bblock. + +Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). +Proof. + intros i. unfold single_inst_block. unfold acc_block. destruct i. + all: simpl; constructor; simpl; auto. +Qed. + +Definition bundlize_inst (i: instruction) := + {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. + +Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. +Proof. + induction c as [|i c]; simpl; auto. + rewrite IHc. destruct i; simpl; auto. +Qed. + +Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). + +Fixpoint bundlize (lb: list bblock) := + match lb with + | nil => nil + | b :: lb => split_bblock b ++ bundlize lb + end. + +Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. +Proof. + intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. +Qed. + +Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. +Proof. + induction lb as [|b lb]; simpl; auto. + rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. +Qed. + +Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. +Proof. + intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. +Qed. + +Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. +Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. *) \ No newline at end of file diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f9f38b18..4bb23e8e 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -838,7 +838,7 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -Obligation Tactic := bblock_auto_correct. +Local Obligation Tactic := bblock_auto_correct. Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := match c with diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index d98e4cd3..de00218e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -22,12 +22,11 @@ Require Import Asmblockgen. Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. -(* Lemma transf_program_match: +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. diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 6b6531c3..7b753506 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -15,826 +15,12 @@ (* *) (* *********************************************************************) -(** Translation from Mach to RISC-V assembly language *) +Require Import Mach Asm Asmblockgen Machblockgen. +Require Import Errors. -Require Archi. -Require Import Coqlib Errors. -Require Import AST Integers Floats Memdata. -Require Import Op Locations Mach Asm. - -Local Open Scope string_scope. Local Open Scope error_monad_scope. -(** The code generation functions take advantage of several - characteristics of the [Mach] code generated by earlier passes of the - compiler, mostly that argument and result registers are of the correct - types. These properties are true by construction, but it's easier to - recheck them during code generation and fail if they do not hold. *) - -(** Extracting integer or float registers. *) - -Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. - -Definition freg_of (r: mreg) : res freg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.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 ::i b" := (cons (A:=instruction) 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) (k: code) := - match make_immed32 n with - | Imm32_single imm => Pmake r imm ::i k - end. - -Definition opimm32 (op: arith_name_rrr) - (opimm: arith_name_rri32) - (rd rs: ireg) (n: int) (k: code) := - match make_immed32 n with - | Imm32_single imm => opimm rd rs imm ::i k - end. - -Definition addimm32 := opimm32 Paddw Paddiw. -Definition andimm32 := opimm32 Pandw Pandiw. -Definition orimm32 := opimm32 Porw Poriw. -Definition xorimm32 := opimm32 Pxorw Pxoriw. -(* -Definition sltimm32 := opimm32 Psltw Psltiw. -Definition sltuimm32 := opimm32 Psltuw Psltiuw. -*) - -Definition loadimm64 (r: ireg) (n: int64) (k: code) := - match make_immed64 n with - | Imm64_single imm => Pmakel r imm ::i k - end. - -Definition opimm64 (op: arith_name_rrr) - (opimm: arith_name_rri64) - (rd rs: ireg) (n: int64) (k: code) := - match make_immed64 n with - | Imm64_single imm => opimm rd rs imm ::i k -end. - -Definition addimm64 := opimm64 Paddl Paddil. -Definition orimm64 := opimm64 Porl Poril. -Definition andimm64 := opimm64 Pandl Pandil. -Definition xorimm64 := opimm64 Pxorl Pxoril. - -(* -Definition sltimm64 := opimm64 Psltl Psltil. -Definition sltuimm64 := opimm64 Psltul Psltiul. -*) - -Definition cast32signed (rd rs: ireg) (k: code) := - if (ireg_eq rd rs) - then Pcvtw2l rd ::i k - else Pmvw2l rd rs ::i k - . - -Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := - if Ptrofs.eq_dec n Ptrofs.zero then - Pmv rd rs ::i k - else - addimm64 rd rs (Ptrofs.to_int64 n) k. - -(** Translation of conditional branches. *) - -Definition transl_comp - (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompw (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. - -Definition transl_compl - (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompl (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k. - -Definition select_comp (n: int) (c: comparison) : option comparison := - if Int.eq n Int.zero then - match c with - | Ceq => Some Ceq - | Cne => Some Cne - | _ => None - end - else - None - . - -Definition transl_opt_compuimm - (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl ::i k - | Some Cne => Pcbu BTwnez r1 lbl ::i k - | Some _ => nil (* Never happens *) - | None => loadimm32 RTMP n (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 - | Ceq => Some Ceq - | Cne => Some Cne - | _ => None - end - else - None - . - -Definition transl_opt_compluimm - (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - match select_compl n c with - | Some Ceq => Pcbu BTdeqz r1 lbl ::i k - | Some Cne => Pcbu BTdnez r1 lbl ::i k - | Some _ => nil (* Never happens *) - | None => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k) - end - . - -Definition transl_cbranch - (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := - match cond, args with - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_opt_compuimm n c r1 lbl k) - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp c Signed r1 r2 lbl k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp c Unsigned r1 r2 lbl k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - Pcb (btest_for_cmpswz c) r1 lbl ::i k - else - loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k) - ) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_opt_compluimm n c r1 lbl k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_compl c Signed r1 r2 lbl k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_compl c Unsigned r1 r2 lbl k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - Pcb (btest_for_cmpsdz c) r1 lbl ::i k - else - loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k) - ) -(*| Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) -*)| _, _ => - Error(msg "Asmgen.transl_cbranch") - end. - -(** Translation of a condition operator. The generated code sets the - [rd] target register to 0 or 1 depending on the truth value of the - condition. *) - -Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. - -Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. - -Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. - -Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) := - Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. - -Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := - Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. - -Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) := - Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. - -Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. - -Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) := - Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. - -Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: code) := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32s c rd r1 r2 k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32u c rd r1 r2 k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32s c rd r1 n k) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32u c rd r1 n k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64s c rd r1 r2 k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64u c rd r1 r2 k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64s c rd r1 n k) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64u c rd r1 n k) -(*| Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) -*)| _, _ => - Error(msg "Asmgen.transl_cond_op") -end. - -(** Translation of the arithmetic operation [r <- op(args)]. - The corresponding instructions are prepended to [k]. *) - -Definition transl_op - (op: operation) (args: list mreg) (res: mreg) (k: code) := - match op, args with - | Omove, a1 :: nil => - match preg_of res, preg_of a1 with - | IR r, IR a => OK (Pmv r a ::i k) - | _ , _ => Error(msg "Asmgen.Omove") - end - | Ointconst n, nil => - do rd <- ireg_of res; - OK (loadimm32 rd n k) - | Olongconst n, nil => - do rd <- ireg_of res; - OK (loadimm64 rd n k) -(*| Ofloatconst f, nil => - do rd <- freg_of res; - OK (if Float.eq_dec f Float.zero - then Pfcvtdw rd GPR0 :: k - else Ploadfi rd f :: k) - | Osingleconst f, nil => - do rd <- freg_of res; - OK (if Float32.eq_dec f Float32.zero - then Pfcvtsw rd GPR0 :: k - else Ploadsi rd f :: k) -*)| Oaddrsymbol s ofs, nil => - do rd <- ireg_of res; - OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) - then Ploadsymbol rd s Ptrofs.zero ::i addptrofs rd rd ofs k - else Ploadsymbol rd s ofs ::i k) - | Oaddrstack n, nil => - do rd <- ireg_of res; - OK (addptrofs rd SP n k) - - | Ocast8signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) - | Ocast16signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k) - | Oadd, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddw rd rs1 rs2 ::i k) - | Oaddimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm32 rd rs n 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) - | 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) -(*| Omulhs, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhw rd rs1 rs2 :: k) - | Omulhu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhuw rd rs1 rs2 :: k) - | Odiv, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivw rd rs1 rs2 :: k) - | Odivu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivuw rd rs1 rs2 :: k) - | Omod, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premw rd rs1 rs2 :: k) - | Omodu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premuw rd rs1 rs2 :: k) -*)| Oand, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandw rd rs1 rs2 ::i k) - | Oandimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm32 rd rs n k) - | Oor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porw rd rs1 rs2 ::i k) - | Oorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm32 rd rs n k) - | Oxor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorw rd rs1 rs2 ::i k) - | Oxorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs n k) - | Oshl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psllw rd rs1 rs2 ::i k) - | Oshlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs n ::i k) - | Oshr, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psraw rd rs1 rs2 ::i k) - | Oshrimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psraiw rd rs n ::i k) - | Oshru, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrlw rd rs1 rs2 ::i k) - | Oshruimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrliw rd rs n ::i k) - | Oshrximm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs ::i k else - Psraiw GPR31 rs (Int.repr 31) ::i - Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i - Paddw GPR31 rs GPR31 ::i - Psraiw rd GPR31 n ::i k) - - (* [Omakelong], [Ohighlong] should not occur *) - | Olowlong, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pcvtl2w rd rs ::i k) - | Ocast32signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (cast32signed rd rs k) - | Ocast32unsigned, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - assertion (ireg_eq rd rs); - OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) - | Oaddl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddl rd rs1 rs2 ::i k) - | Oaddlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm64 rd rs n k) - | Onegl, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pnegl rd rs ::i k) - | 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) - | 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) -(*| Omullhs, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhl rd rs1 rs2 :: k) - | Omullhu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhul rd rs1 rs2 :: k) - | Odivl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivl rd rs1 rs2 :: k) - | Odivlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivul rd rs1 rs2 :: k) - | Omodl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Preml rd rs1 rs2 :: k) - | Omodlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premul rd rs1 rs2 :: k) -*)| Oandl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandl rd rs1 rs2 ::i k) - | Oandlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm64 rd rs n k) - | Oorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porl rd rs1 rs2 ::i k) - | Oorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm64 rd rs n k) - | Oxorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorl rd rs1 rs2 ::i k) - | Oxorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs n k) - | Oshll, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pslll rd rs1 rs2 ::i k) - | Oshllimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psllil rd rs n ::i k) - | Oshrl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psral rd rs1 rs2 ::i k) - | Oshrlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrail rd rs n ::i k) - | Oshrlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrll rd rs1 rs2 ::i k) - | Oshrluimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrlil rd rs n ::i k) -(*| Oshrxlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psrail GPR31 rs (Int.repr 63) :: - Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: - Paddl GPR31 rs GPR31 :: - Psrail rd GPR31 n :: k) - -*)| Onegf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegd rd rs ::i k) -(*| Oabsf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabsd rd rs :: k) - | Oaddf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfaddd rd rs1 rs2 :: k) - | Osubf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsubd rd rs1 rs2 :: k) - | Omulf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmuld rd rs1 rs2 :: k) - | Odivf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdivd rd rs1 rs2 :: k) - - | Onegfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegs rd rs :: k) - | Oabsfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabss rd rs :: k) - | Oaddfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfadds rd rs1 rs2 :: k) - | Osubfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsubs rd rs1 rs2 :: k) - | Omulfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmuls rd rs1 rs2 :: k) - | Odivfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdivs rd rs1 rs2 :: k) - - | Osingleoffloat, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtsd rd rs :: k) - | Ofloatofsingle, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtds rd rs :: k) - - | Ointoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwd rd rs :: k) - | Ointuoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwud rd rs :: k) - | Ofloatofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdw rd rs :: k) - | Ofloatofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdwu rd rs :: k) - | Ointofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtws rd rs :: k) - | Ointuofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwus rd rs :: k) - | Osingleofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtsw rd rs :: k) - | Osingleofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtswu rd rs :: k) - - | Olongoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtld rd rs :: k) - | Olonguoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtlud rd rs :: k) - | Ofloatoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdl rd rs :: k) - | Ofloatoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdlu rd rs :: k) - | Olongofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtls rd rs :: k) - | Olonguofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtlus rd rs :: k) - | Osingleoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtsl rd rs :: k) - | Osingleoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtslu rd rs :: k) - -*)| Ocmp cmp, _ => - do rd <- ireg_of res; - transl_cond_op cmp rd args k - - | _, _ => - Error(msg "Asmgen.transl_op") - end. - -(** Accessing data in the stack frame. *) - -Definition indexed_memory_access - (mk_instr: ireg -> offset -> instruction) - (base: ireg) (ofs: ptrofs) (k: code) := - match make_immed64 (Ptrofs.to_int64 ofs) with - | Imm64_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) ::i k -(*| Imm64_pair hi lo => - Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k - | Imm64_large imm => - Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k -*)end. - -Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := - match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k) - | _, _ => Error (msg "Asmgen.loadind") - end. - -Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := - match ty, preg_of src with - | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k) - | _, _ => Error (msg "Asmgen.storeind") - end. - -Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) := - indexed_memory_access (Pld dst) base ofs k. - -Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) := - indexed_memory_access (Psd src) base ofs k. - -(** Translation of memory accesses: loads, and stores. *) - -Definition transl_memory_access - (mk_instr: ireg -> offset -> instruction) - (addr: addressing) (args: list mreg) (k: code) : res (list instruction) := - match addr, args with - | Aindexed ofs, a1 :: nil => - do rs <- ireg_of a1; - OK (indexed_memory_access mk_instr rs ofs k) - | Aglobal id ofs, nil => - OK (Ploadsymbol GPR31 id ofs ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) - | Ainstack ofs, nil => - OK (indexed_memory_access mk_instr SP ofs k) - | _, _ => - Error(msg "Asmgen.transl_memory_access") - end. - -Definition transl_load (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: code) : res (list instruction) := - match chunk with - | Mint8signed => - do r <- ireg_of dst; - transl_memory_access (Plb r) addr args k - | Mint8unsigned => - do r <- ireg_of dst; - transl_memory_access (Plbu r) addr args k - | Mint16signed => - do r <- ireg_of dst; - transl_memory_access (Plh r) addr args k - | Mint16unsigned => - do r <- ireg_of dst; - transl_memory_access (Plhu r) addr args k - | Mint32 => - do r <- ireg_of dst; - transl_memory_access (Plw r) addr args k - | Mint64 => - do r <- ireg_of dst; - transl_memory_access (Pld r) addr args k - | Mfloat32 => - do r <- freg_of dst; - transl_memory_access (Pfls r) addr args k - | Mfloat64 => - do r <- freg_of dst; - transl_memory_access (Pfld r) addr args k - | _ => - Error (msg "Asmgen.transl_load") - end. - -Definition transl_store (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: code) : res (list instruction) := - match chunk with - | Mint8signed | Mint8unsigned => - do r <- ireg_of src; - transl_memory_access (Psb r) addr args k - | Mint16signed | Mint16unsigned => - do r <- ireg_of src; - transl_memory_access (Psh r) addr args k - | Mint32 => - do r <- ireg_of src; - transl_memory_access (Psw r) addr args k - | Mint64 => - do r <- ireg_of src; - transl_memory_access (Psd r) addr args k - | Mfloat32 => - do r <- freg_of src; - transl_memory_access (Pfss r) addr args k - | Mfloat64 => - do r <- freg_of src; - transl_memory_access (Pfsd r) addr args k - | _ => - Error (msg "Asmgen.transl_store") - end. - -(** Function epilogue *) - -Definition make_epilogue (f: Mach.function) (k: code) := - loadind_ptr SP f.(fn_retaddr_ofs) GPR8 - (Pset RA GPR8 ::i Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::i k). - -(** Translation of a Mach instruction. *) - -Definition transl_instr (f: Mach.function) (i: Mach.instruction) - (ep: bool) (k: code) := - match i with - | Mgetstack ofs ty dst => - loadind SP ofs ty dst k - | Msetstack src ofs ty => - storeind src SP ofs ty k - | Mgetparam ofs ty dst => - (* load via the frame pointer if it is valid *) - do c <- loadind FP ofs ty dst k; - OK (if ep then c - else loadind_ptr SP f.(fn_link_ofs) FP c) - | Mop op args res => - transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k - | Mstore chunk addr args src => - transl_store chunk addr args src k -(*| Mcall sig (inl r) => - do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) -*)| Mcall sig (inr symb) => - OK ((Pcall symb) ::i k) -(*| Mtailcall sig (inl r) => - do r1 <- ireg_of r; - OK (make_epilogue f (Pcall :: k)) -*)| Mtailcall sig (inr symb) => - OK (make_epilogue f ((Pgoto symb) ::i k)) - | Mbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::i k) - | Mlabel lbl => - OK (Plabel lbl ::i k) - | Mgoto lbl => - OK (Pj_l lbl ::i k) - | Mcond cond args lbl => - transl_cbranch cond args lbl k -(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) -*)| Mreturn => - OK (make_epilogue f (Pret ::i k)) - (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) - | _ => - Error (msg "Asmgen.transl_instr") - end. - -(** Translation of a code sequence *) - -Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := - match i with - | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst R10) - | Mop op args res => before && negb (mreg_eq res R10) - | _ => false - end. - -(** This is the naive definition that we no longer use because it - is not tail-recursive. It is kept as specification. *) - -Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := - match il with - | nil => OK nil - | i1 :: il' => - do k <- transl_code f il' (it1_is_parent it1p i1); - transl_instr f i1 it1p k - end. - -(** This is an equivalent definition in continuation-passing style - that runs in constant stack space. *) - -Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) - (it1p: bool) (k: code -> res code) := - match il with - | nil => k nil - | i1 :: il' => - transl_code_rec f il' (it1_is_parent it1p i1) - (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) - end. - -Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := - transl_code_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, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) - -Definition transl_function (f: Mach.function) := - do c <- transl_code' f f.(Mach.fn_code) true; - OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i - Pget GPR8 RA ::i - storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)). - -Definition transf_function (f: Mach.function) : res Asm.function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := - transf_partial_fundef transf_function f. - Definition transf_program (p: Mach.program) : res Asm.program := - transform_partial_program transf_fundef p. + let mbp := Machblockgen.transf_program p in + do abp <- Asmblockgen.transf_program mbp; + OK (Asm.transf_program abp). \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 896e9ce9..87c4184b 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -15,1092 +15,52 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Mach Conventions Asm. -Require Import Asmgen Asmgenproof0 Asmgenproof1. +Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. +Require Import Machblockgenproof Asmblockgenproof. -Definition match_prog (p: Mach.program) (tp: Asm.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. +(* Local Open Scope linking_scope. + +Definition block_passes := + mkpass Machblockgenproof.match_prog + ::: mkpass Asmblockgenproof.match_prog + ::: mkpass Asm.match_prog + ::: pass_nil _. + *) + +Inductive match_prog : Mach.program -> Asm.program -> Prop := + | mk_match_prog: forall p mbp abp tp, + Machblockgen.transf_program p = mbp -> Machblockgenproof.match_prog p mbp -> + Asmblockgen.transf_program mbp = OK abp -> Asmblockgenproof.match_prog mbp abp -> + Asm.match_prog abp tp -> + match_prog p tp. Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. + forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. Proof. - intros. eapply match_transform_partial_program; eauto. + intros p tp H. + unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. + inversion_clear H. inversion_clear H1. remember (Machblockgen.transf_program p) as mbp. + constructor 1 with (mbp:=mbp) (abp:=x); auto. + subst. apply Machblockgenproof.transf_program_match. + apply Asmblockgenproof.transf_program_match. auto. + apply Asm.transf_program_match. auto. Qed. Section PRESERVATION. Variable prog: Mach.program. -Variable tprog: Asm.program. +Variable tprog: program. Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -(** * Properties of control flow *) - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - omega. -Qed. - -Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inv H. - eapply exec_straight_steps_1; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c ep tf tc c' ep' tc' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - transl_code f c' ep' = OK tc' -> - exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. -Proof. - intros. inv H. - exploit exec_straight_steps_2; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -Remark loadimm32_label: - forall r n k, tail_nolabel k (loadimm32 r n k). -Proof. - intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm32_label: labels. - -Remark opimm32_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm32 op opimm r1 r2 n k). -Proof. - intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm32_label: labels. - -Remark loadimm64_label: - forall r n k, tail_nolabel k (loadimm64 r n k). -Proof. - intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm64_label: labels. - -Remark cast32signed_label: - forall rd rs k, tail_nolabel k (cast32signed rd rs k). -Proof. - intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. -Qed. -Hint Resolve cast32signed_label: labels. - -Remark opimm64_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm64 op opimm r1 r2 n k). -Proof. - intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm64_label: labels. - -Remark addptrofs_label: - forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). -Proof. - unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. - apply opimm64_label; TailNoLabel. -Qed. -Hint Resolve addptrofs_label: labels. -(* -Remark transl_cond_float_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_float; intros. destruct c; inv H; exact I. -Qed. - -Remark transl_cond_single_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_single; intros. destruct c; inv H; exact I. -Qed. -*) -Remark transl_cbranch_label: - forall cond args lbl k c, - transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. -(* Ccomp *) - - unfold transl_comp; TailNoLabel. -(* Ccompu *) - - unfold transl_comp; TailNoLabel. -(* Ccompimm *) - - destruct (Int.eq n Int.zero); TailNoLabel. - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. -(* Ccompuimm *) - - unfold transl_opt_compuimm. - remember (select_comp n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; - destruct (Int.eq n Int.zero); destruct c0; discriminate. - + unfold loadimm32; - destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. -(* Ccompl *) - - unfold transl_compl; TailNoLabel. -(* Ccomplu *) - - unfold transl_compl; TailNoLabel. -(* Ccomplimm *) - - destruct (Int64.eq n Int64.zero); TailNoLabel. - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. -(* Ccompluimm *) - - unfold transl_opt_compluimm. - remember (select_compl n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; - destruct (Int64.eq n Int64.zero); destruct c0; discriminate. - + unfold loadimm64; - destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. -Qed. - -(* -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -*) - -Remark transl_cond_op_label: - forall cond args r k c, - transl_cond_op cond r args k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. -- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. -Qed. - -Remark transl_op_label: - forall op args r k c, - transl_op op args r k = OK c -> tail_nolabel k c. -Proof. -Opaque Int.eq. - unfold transl_op; intros; destruct op; TailNoLabel. -(* Omove *) -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -(* Oaddrsymbol *) -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. -(* Oaddimm32 *) -- apply opimm32_label; intros; exact I. -(* Oandimm32 *) -- apply opimm32_label; intros; exact I. -(* Oorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oxorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oshrximm *) -- destruct (Int.eq n Int.zero); TailNoLabel. -(* Oaddimm64 *) -- apply opimm64_label; intros; exact I. -(* Oandimm64 *) -- apply opimm64_label; intros; exact I. -(* Oorimm64 *) -- apply opimm64_label; intros; exact I. -(* Oxorimm64 *) -- apply opimm64_label; intros; exact I. -(* Ocmp *) -- eapply transl_cond_op_label; eauto. -Qed. - -(* -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -- destruct (Float.eq_dec n Float.zero); TailNoLabel. -- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. -+ TailNoLabel. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- eapply transl_cond_op_label; eauto. -*) - -Remark indexed_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) base ofs k, - (forall r o, nolabel (mk_instr r o)) -> - tail_nolabel k (indexed_memory_access mk_instr base ofs k). -Proof. - unfold indexed_memory_access; intros. - (* destruct Archi.ptr64. *) - destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. - (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) -Qed. - -Remark loadind_label: - forall base ofs ty dst k c, - loadind base ofs ty dst k = OK c -> tail_nolabel k c. -Proof. - unfold loadind; intros. - destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark storeind_label: - forall src base ofs ty k c, - storeind src base ofs ty k = OK c -> tail_nolabel k c. -Proof. - unfold storeind; intros. - destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark loadind_ptr_label: - forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. - -Remark storeind_ptr_label: - forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. - -Remark transl_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) addr args k c, - (forall r o, nolabel (mk_instr r o)) -> - transl_memory_access mk_instr addr args k = OK c -> - tail_nolabel k c. -Proof. - unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. -Qed. - -Remark make_epilogue_label: - forall f k, tail_nolabel k (make_epilogue f k). -Proof. - unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. -Qed. - -Lemma transl_instr_label: - forall f i ep k c, - transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. -Proof. - unfold transl_instr; intros; destruct i; TailNoLabel. -(* loadind *) -- eapply loadind_label; eauto. -(* storeind *) -- eapply storeind_label; eauto. -(* Mgetparam *) -- destruct ep. eapply loadind_label; eauto. - eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. -(* transl_op *) -- eapply transl_op_label; eauto. -(* transl_load *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -(* transl store *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; TailNoLabel. -- destruct s0; monadInv H; eapply tail_nolabel_trans - ; [eapply make_epilogue_label|TailNoLabel]. -- eapply transl_cbranch_label; eauto. -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -Qed. -(* - - -- eapply transl_op_label; eauto. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -*) - -Lemma transl_instr_label': - forall lbl f i ep k c, - transl_instr f i ep k = OK c -> - find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply B). - intros. subst c. simpl. auto. -Qed. - -Lemma transl_code_label: - forall lbl f c ep tc, - transl_code f c ep = OK tc -> - match Mach.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). - generalize (Mach.is_label_correct lbl a). - destruct (Mach.is_label lbl a); intros. - subst a. simpl in EQ. exists x; auto. - eapply IHc; eauto. -Qed. - -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match Mach.find_label lbl f.(Mach.fn_code) with - | None => find_label lbl tf.(fn_code) = None - | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. - (* destruct B. *) - eapply transl_code_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 -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros [tc [A B]]. - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -Lemma return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmgenproof0.return_address_exists; eauto. -- intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. - rewrite transl_code'_transl_code in EQ0. - exists x; exists true; split; auto. unfold fn_code. - constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x). -- 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. -*) - -Inductive match_states: Mach.state -> Asm.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Mach.State s fb sp c ms m) - (Asm.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Mach.Callstate s fb ms m) - (Asm.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Mach.Returnstate s ms m) - (Asm.State rs m'). - -Lemma exec_straight_steps: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists rs2, - exec_straight tge tf c rs1 m1' k rs2 m2' - /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c ms2 m2) st'. -Proof. - intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B C]]]. - exists (State rs2 m2'); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. - -Lemma exec_straight_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. - -Lemma exec_straight_opt_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - inv A. -- exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -- exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the 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. *) - -Definition measure (s: Mach.state) : nat := - match s with - | Mach.State _ _ _ _ _ _ => 0%nat - | Mach.Callstate _ _ _ _ => 0%nat - | Mach.Returnstate _ _ _ => 1%nat - end. - -Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of R10). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) - -Theorem step_simulation: - forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros; inv MS. - -- (* Mlabel *) - left; eapply exec_straight_steps; eauto; intros. - monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. apply agree_nextinstr; auto. simpl; congruence. - -- (* Mgetstack *) - unfold load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto with asmgen. congruence. - simpl; congruence. - - -- (* Msetstack *) - unfold store_stack in H. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - left; eapply exec_straight_steps; eauto. - rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - inversion TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. - exists rs'; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. - -- (* Mgetparam *) - assert (f0 = f) by congruence; subst f0. - unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. -(* Opaque loadind. *) - left; eapply exec_straight_steps; eauto; intros. monadInv TR. - destruct ep. -(* GPR31 contains parent *) - exploit loadind_correct. eexact EQ. - instantiate (2 := rs0). rewrite DXP; eauto. congruence. - intros [rs1 [P [Q R]]]. - exists rs1; split. eauto. - split. 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. congruence. intros [rs1 [P [Q R]]]. - exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. - intros [rs2 [S [T U]]]. - exists rs2; split. eapply exec_straight_trans; eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs1#FP <- (rs2#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. -- (* Mop *) - assert (eval_operation tge sp op (map rs args) m = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. split. auto. - apply agree_set_undef_mreg with rs0; 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. - -- (* Mload *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - inversion TR. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. congruence. - intros; auto with asmgen. - simpl; congruence. - - -- (* Mstore *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - left; eapply exec_straight_steps; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - exists rs2; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. - -- (* Mcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct ros as [rf|fid]; simpl in H; monadInv H5. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. -*) -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. -*) -+ (* Direct call *) - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - 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 H. auto. } - -- (* Mbuiltin *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_builtin. eauto. eauto. - eapply find_instr_tail; eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x). - unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H1. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. - congruence. - -- (* Mgoto *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H4. - exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. - left; exists (State rs' m'); split. - apply plus_one. econstructor; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - econstructor; eauto. - eapply agree_exten; eauto with asmgen. - congruence. -- (* Mcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_opt_steps_goto; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exists jmp; exists k; exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - exact B. -- (* Mcond false *) - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). - exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - simpl. congruence. -- (* Mjumptable *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H6. -(* - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H5); intro NOOV. - exploit find_label_goto_label. eauto. eauto. - instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). - Simpl. eauto. - eauto. - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H. intros LD; inv LD. - left; econstructor; split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail; eauto. - simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. - econstructor; eauto. - eapply agree_undef_regs; eauto. - simpl. intros. rewrite C; auto with asmgen. Simpl. - congruence. -*) -- (* Mreturn *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. simpl in H6; monadInv H6. - assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - -- (* internal function *) - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. - unfold store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i - Pget GPR8 RA ::i - storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. - set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPR8 = rs0 RA). { apply V'. } - assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - rewrite H3. rewrite H4. - (* change (rs' GPR8) with (rs0 RA). *) - rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. - congruence. congruence. - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: - exec_straight tge tf - tf.(fn_code) rs0 m' - x0 rs3 m3'). - { change (fn_code tf) with tfbody; unfold tfbody. - apply exec_straight_step with rs2 m2'. - unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. - reflexivity. - eapply exec_straight_trans. - - eexact U'. - - eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite V. - assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H6; 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 V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. - -- (* external function *) - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. apply agree_set_pair; auto. - -- (* return *) - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, Mach.initial_state prog st1 -> - exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - Theorem transf_program_correct: - forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). + forward_simulation (Mach.semantics (inv_trans_rao return_address_offset) prog) (Asm.semantics tprog). Proof. - eapply forward_simulation_star with (measure := measure). - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact step_simulation. + inv TRANSF. + eapply compose_forward_simulations. apply Machblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + apply Asm.transf_program_correct. eauto. Qed. End PRESERVATION. diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index aa54e8a2..c20889b7 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -574,5 +574,5 @@ Definition trans_function (f: Mach.function) : function := Definition trans_fundef (f: Mach.fundef) : fundef := transf_fundef trans_function f. -Definition trans_prog (src: Mach.program) : program := +Definition transf_program (src: Mach.program) : program := transform_program trans_fundef src. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 62391792..ff9c29d3 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -23,7 +23,7 @@ Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.func Definition match_prog (p: Mach.program) (tp: Machblock.program) := match_program (fun _ f tf => tf = trans_fundef f) eq p tp. -Lemma trans_program_match: forall p, match_prog p (trans_prog p). +Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. intros. eapply match_transform_program; eauto. Qed. @@ -461,8 +461,7 @@ Proof. destruct ei; (contradict Hexit; discriminate) || ( inversion Hexit; subst; inversion Hstep; subst; simpl ). - * unfold inv_trans_rao in H11. - eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. apply exec_MBcall with (f := (trans_function f0)); auto. rewrite find_function_ptr_same in H9; auto. * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. @@ -600,7 +599,8 @@ Proof. eapply exec_return. Qed. -Theorem simulation: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). +Theorem transf_program_correct: + forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) -- cgit From 3a244908dd9233100075ffe889b3da493cdf9c38 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Sep 2018 11:40:07 +0200 Subject: Remplacement de match_prog par un plus classique --- mppa_k1c/Asm.v | 85 ++++++++++++++++++++++++++++++-------------- mppa_k1c/Asmgenproof.v | 23 +++++------- mppa_k1c/Machblockgenproof.v | 4 +-- 3 files changed, 70 insertions(+), 42 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d71304fa..f0284c26 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -359,11 +359,7 @@ Proof. intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. Qed. -Definition transf_fundef (f: Asmblock.fundef) : fundef := - match f with - | Internal f => Internal (transf_function f) - | External ef => External ef - end. +Definition transf_fundef : Asmblock.fundef -> fundef := AST.transf_fundef transf_function. Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. Proof. @@ -371,7 +367,7 @@ Proof. rewrite transf_function_proj. auto. Qed. -Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit := +(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit := match gd with | Gfun f => Gfun (transf_fundef f) | Gvar gu => Gvar gu @@ -398,16 +394,11 @@ Proof. rewrite transf_globdef_proj. congruence. Qed. + *) -Definition transf_program (p: Asmblock.program) : program := - {| prog_defs := transf_prog_defs (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -Definition match_prog (p: Asmblock.program) (tp: program) := (p = program_proj tp). +Definition transf_program : Asmblock.program -> program := transform_program transf_fundef. -Lemma asmblock_program_equals: forall (p1 p2: Asmblock.program), +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 -> @@ -416,14 +407,47 @@ 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: Asmblock.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 p tp H. unfold match_prog. - unfold transf_program in H. - destruct tp as [tdefs tpub tmain]. inv H. - unfold program_proj. simpl. apply asmblock_program_equals; simpl; auto. - apply transf_prog_proj. + 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. @@ -436,16 +460,25 @@ 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 (Asmblock.semantics prog) (semantics tprog). Proof. - inversion TRANSF. (* inv H0. *) - eapply forward_simulation_step with (match_states := match_states). - all: try (simpl; congruence). - - simpl. intros s1 H1. exists s1. split; auto. congruence. - - simpl. intros s1 t s1' H1 s2 H2. exists s1'. split. - + congruence. - + unfold match_states. auto. + 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. \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 87c4184b..20691183 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -18,32 +18,26 @@ Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. Require Import Machblockgenproof Asmblockgenproof. -(* Local Open Scope linking_scope. +Local Open Scope linking_scope. Definition block_passes := mkpass Machblockgenproof.match_prog ::: mkpass Asmblockgenproof.match_prog ::: mkpass Asm.match_prog ::: pass_nil _. - *) -Inductive match_prog : Mach.program -> Asm.program -> Prop := - | mk_match_prog: forall p mbp abp tp, - Machblockgen.transf_program p = mbp -> Machblockgenproof.match_prog p mbp -> - Asmblockgen.transf_program mbp = OK abp -> Asmblockgenproof.match_prog mbp abp -> - Asm.match_prog abp tp -> - match_prog p tp. +Definition match_prog := pass_match (compose_passes block_passes). Lemma transf_program_match: forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. - inversion_clear H. inversion_clear H1. remember (Machblockgen.transf_program p) as mbp. - constructor 1 with (mbp:=mbp) (abp:=x); auto. - subst. apply Machblockgenproof.transf_program_match. - apply Asmblockgenproof.transf_program_match. auto. - apply Asm.transf_program_match. auto. + inversion_clear H. inversion H1. 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. + exists tp; split. apply Asm.transf_program_match; auto. auto. Qed. Section PRESERVATION. @@ -57,7 +51,8 @@ Let tge := Genv.globalenv tprog. Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao return_address_offset) prog) (Asm.semantics tprog). Proof. - inv TRANSF. + unfold match_prog in TRANSF. simpl in TRANSF. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. eapply compose_forward_simulations. apply Machblockgenproof.transf_program_correct; eauto. eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. apply Asm.transf_program_correct. eauto. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index ff9c29d3..45ea53cc 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -23,9 +23,9 @@ Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.func Definition match_prog (p: Mach.program) (tp: Machblock.program) := match_program (fun _ f tf => tf = trans_fundef f) eq p tp. -Lemma transf_program_match: forall p, match_prog p (transf_program p). +Lemma transf_program_match: forall p tp, transf_program p = tp -> match_prog p tp. Proof. - intros. eapply match_transform_program; eauto. + intros. rewrite <- H. eapply match_transform_program; eauto. Qed. Definition trans_stackframe (msf: Mach.stackframe) : stackframe := -- cgit From 5a78e28f0bd7e8f822d96c4ad24ab20cca8fedd1 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 5 Sep 2018 12:20:05 +0200 Subject: resoud pb du TransfLink --- mppa_k1c/Asmgenproof.v | 2 ++ 1 file changed, 2 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 20691183..09564718 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -59,3 +59,5 @@ Proof. Qed. End PRESERVATION. + +Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). \ No newline at end of file -- cgit From 672d9ea4489158f6a6b7175463c6514a91d1490d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Sep 2018 15:15:48 +0200 Subject: Rajout d'un return_address_offset. Besoin de changer forward_simu de mach machblock --- mppa_k1c/Asmblockgen.v | 4 ++-- mppa_k1c/Asmgen.v | 13 ++++++++++++- mppa_k1c/Asmgenproof.v | 24 ++++++++++++++++++++++-- mppa_k1c/Machblockgen.v | 8 ++++---- mppa_k1c/Machblockgenproof.v | 20 ++++++++++---------- 5 files changed, 50 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 4bb23e8e..79c28fe9 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -872,7 +872,7 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) := end . -Definition transl_function (f: Machblock.function) := +Definition transf_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code); OK (mkfunction f.(Machblock.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b @@ -889,7 +889,7 @@ Definition transl_function (f: Machblock.function) := Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := - transf_partial_fundef transl_function f. + transf_partial_fundef transf_function f. Definition transf_program (p: Machblock.program) : res Asmblock.program := transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 7b753506..15892818 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -23,4 +23,15 @@ Local Open Scope error_monad_scope. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := Machblockgen.transf_program p in do abp <- Asmblockgen.transf_program mbp; - OK (Asm.transf_program abp). \ No newline at end of file + OK (Asm.transf_program abp). + +Definition transf_function (f: Mach.function) : res function := + let mbf := Machblockgen.transf_function f in + do abf <- Asmblockgen.transf_function mbf; + OK (Asm.transf_function abf). + +Definition transl_code (f: Mach.function) (l: Mach.code) : res (list instruction) := + let mbf := Machblockgen.transf_function f in + let mbc := Machblockgen.trans_code l in + do abc <- transl_blocks mbf mbc; + OK (unfold abc). \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 09564718..5660f718 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -40,6 +40,25 @@ Proof. exists tp; split. apply Asm.transf_program_match; auto. auto. Qed. +(** Return Address Offset *) + +Inductive code_tail: Z -> code -> code -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos i c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + 1) (i :: c1) c2. + +Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := + forall tf tc, + Asmgen.transf_function f = OK tf -> + Asmgen.transl_code f c = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_code tf) tc. + +Axiom return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. + Section PRESERVATION. Variable prog: Mach.program. @@ -49,7 +68,7 @@ Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Theorem transf_program_correct: - forward_simulation (Mach.semantics (inv_trans_rao return_address_offset) prog) (Asm.semantics tprog). + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. unfold match_prog in TRANSF. simpl in TRANSF. inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. @@ -60,4 +79,5 @@ Qed. End PRESERVATION. -Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). \ No newline at end of file +Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). + diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index c20889b7..1d5555df 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -563,7 +563,7 @@ Proof. Qed. (* à finir pour passer des Mach.function au function, etc. *) -Definition trans_function (f: Mach.function) : function := +Definition transf_function (f: Mach.function) : function := {| fn_sig:=Mach.fn_sig f; fn_code:=trans_code (Mach.fn_code f); fn_stacksize := Mach.fn_stacksize f; @@ -571,8 +571,8 @@ Definition trans_function (f: Mach.function) : function := fn_retaddr_ofs := Mach.fn_retaddr_ofs f |}. -Definition trans_fundef (f: Mach.fundef) : fundef := - transf_fundef trans_function f. +Definition transf_fundef (f: Mach.fundef) : fundef := + transf_fundef transf_function f. Definition transf_program (src: Mach.program) : program := - transform_program trans_fundef src. + transform_program transf_fundef src. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 45ea53cc..62c1e0ed 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -18,10 +18,10 @@ Require Import Machblockgen. Require Import ForwardSimulationBlock. Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := - rao (trans_function f) (trans_code c). + rao (transf_function f) (trans_code c). Definition match_prog (p: Mach.program) (tp: Machblock.program) := - match_program (fun _ f tf => tf = trans_fundef f) eq p tp. + 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. @@ -90,7 +90,7 @@ Proof (match_program_main 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 /\ trans_fundef f = tf. + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. Proof. intros. exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. @@ -110,7 +110,7 @@ Qed. Lemma find_funct_ptr_same: forall f f0, Genv.find_funct_ptr ge f = Some (Internal f0) -> - Genv.find_funct_ptr tge f = Some (Internal (trans_function f0)). + Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). Proof. intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. Qed. @@ -295,15 +295,15 @@ Qed. Lemma find_label_preserved: forall l f c, Mach.find_label l (Mach.fn_code f) = Some c -> - exists h, In l h /\ find_label l (fn_code (trans_function f)) = Some (concat h (trans_code c)). + exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). Proof. - intros. cutrewrite ((fn_code (trans_function f)) = trans_code (Mach.fn_code f)); eauto. + intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. apply find_label_transcode_preserved; auto. Qed. Lemma mem_free_preserved: forall m stk f, - Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (trans_function f)). + Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). Proof. intros. auto. Qed. @@ -462,10 +462,10 @@ Proof. inversion Hexit; subst; inversion Hstep; subst; simpl ). * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - apply exec_MBcall with (f := (trans_function f0)); auto. + apply exec_MBcall with (f := (transf_function f0)); auto. rewrite find_function_ptr_same in H9; auto. * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - apply exec_MBtailcall with (f := (trans_function f0)); auto. + apply exec_MBtailcall with (f := (transf_function f0)); auto. rewrite find_function_ptr_same in H9; auto. rewrite parent_sp_preserved in H11; subst; auto. rewrite parent_ra_preserved in H12; subst; auto. @@ -582,7 +582,7 @@ Proof. inversion H1; subst; clear H1. inversion_clear H0; simpl. - (* function_internal*) - cutrewrite (trans_code (Mach.fn_code f0) = fn_code (trans_function f0)); eauto. + cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. eapply exec_function_internal; eauto. rewrite <- parent_sp_preserved; eauto. rewrite <- parent_ra_preserved; eauto. -- cgit From 95926365caa7577f0936cdd4ab705d28b3d1457d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 5 Sep 2018 17:25:56 +0200 Subject: une solution pour le rao -> on fait remonter dans Asmblockgenproof --- mppa_k1c/Asmgenproof.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 5660f718..32e8e8a8 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -50,10 +50,7 @@ Inductive code_tail: Z -> code -> code -> Prop := code_tail (pos + 1) (i :: c1) c2. Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - forall tf tc, - Asmgen.transf_function f = OK tf -> - Asmgen.transl_code f c = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_code tf) tc. + Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. Axiom return_address_exists: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> @@ -72,7 +69,10 @@ Theorem transf_program_correct: Proof. unfold match_prog in TRANSF. simpl in TRANSF. inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. - eapply compose_forward_simulations. apply Machblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + intros X; apply X. eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. apply Asm.transf_program_correct. eauto. Qed. -- cgit From d870e17a7a964b48d8e44195ccd12e4160a63f32 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Sep 2018 11:43:28 +0200 Subject: Extraction issue --- mppa_k1c/Asm.v | 15 ++++++++++++++- mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/extractionMachdep.v | 2 ++ 3 files changed, 18 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f0284c26..5229e364 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -30,10 +30,15 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. -Require Import Asmblock. +Require Import Asmblock Asmblockgen. Require Import Linking. Require Import Errors. +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +(** Syntax *) Inductive instruction : Type := (** pseudo instructions *) | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) @@ -251,6 +256,11 @@ Definition basic_to_instruction (b: basic) := Section RELSEM. +(** For OCaml code *) +Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n). +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + basic_to_instruction (storeind_ptr src base ofs). + Definition code := list instruction. Fixpoint unfold_label (ll: list label) := @@ -282,6 +292,9 @@ Fixpoint unfold (lb: bblocks) := Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; correct: unfold fn_blocks = fn_code }. +(* For OCaml code *) +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. + Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. Definition genv := Genv.t fundef unit. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index b3a1e836..20abfc38 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -47,9 +47,9 @@ let align n a = (n + a - 1) land (-a) List.iter emit (Asmgen.loadimm32 dst n []) *) let expand_addptrofs dst src n = - List.iter emit (Asmgen.addptrofs dst src n []) + List.iter emit (Asm.addptrofs dst src n []) let expand_storeind_ptr src base ofs = - List.iter emit (Asmgen.storeind_ptr src base ofs []) + List.iter emit (Asm.storeind_ptr src base ofs []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v index c9a1040a..e70f51de 100644 --- a/mppa_k1c/extractionMachdep.v +++ b/mppa_k1c/extractionMachdep.v @@ -23,5 +23,7 @@ Extract Constant Archi.ptr64 => " Configuration.model = ""64"" ". Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) (* Asm *) +(* Extract Constant Asm.low_half => "fun _ _ _ -> assert false". Extract Constant Asm.high_half => "fun _ _ _ -> assert false". +*) -- cgit From 36be538c1c3e5cbbbd45d9b2a8b8bb9712a21dd0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Sep 2018 15:56:36 +0200 Subject: Asmblock & cie - ça compile MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 7 +-- mppa_k1c/Asmexpand.ml | 40 ++++++------ mppa_k1c/Asmgen.v | 12 +++- mppa_k1c/TargetPrinter.ml | 154 +++++++++++++++++++++------------------------- 4 files changed, 101 insertions(+), 112 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 5229e364..14824b85 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -30,7 +30,7 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. -Require Import Asmblock Asmblockgen. +Require Import Asmblock. Require Import Linking. Require Import Errors. @@ -256,11 +256,6 @@ Definition basic_to_instruction (b: basic) := Section RELSEM. -(** For OCaml code *) -Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n). -Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := - basic_to_instruction (storeind_ptr src base ofs). - Definition code := list instruction. Fixpoint unfold_label (ll: list label) := diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 20abfc38..81c3cf48 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -20,6 +20,7 @@ of the RISC-V assembly code. *) open Asm +open Asmgen open Asmexpandaux open AST open Camlcoq @@ -47,9 +48,9 @@ let align n a = (n + a - 1) land (-a) List.iter emit (Asmgen.loadimm32 dst n []) *) let expand_addptrofs dst src n = - List.iter emit (Asm.addptrofs dst src n []) + List.iter emit (addptrofs dst src n :: []) let expand_storeind_ptr src base ofs = - List.iter emit (Asm.storeind_ptr src base ofs []) + List.iter emit (storeind_ptr src base ofs :: []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack @@ -61,7 +62,7 @@ let expand_storeind_ptr src base ofs = (* Fix-up code around calls to variadic functions. Floating-point arguments residing in FP registers need to be moved to integer registers. *) -let int_param_regs = [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |] +let int_param_regs = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |] (* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) let float_param_regs = [| |] @@ -330,7 +331,7 @@ let rec args_size sz = function let arguments_size sg = args_size 0 sg.sig_args -let save_arguments first_reg base_ofs = +let save_arguments first_reg base_ofs = let open Asmblock in for i = first_reg to 7 do expand_storeind_ptr int_param_regs.(i) @@ -412,7 +413,7 @@ let expand_bswap64 d s = assert false (* Handling of compiler-inlined builtins *) -let expand_builtin_inline name args res = +let expand_builtin_inline name args res = let open Asmblock in match name, args, res with (* Synchronization *) | "__builtin_membar", [], _ -> @@ -438,32 +439,32 @@ let expand_builtin_inline name args res = let expand_instruction instr = match instr with - | PExpand Pallocframe (sz, ofs) -> + | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (PArith (PArithRR (Pmv, GPR10, GPR12))); + emit (Pmv (Asmblock.GPR10, Asmblock.GPR12)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg full_sz)); - expand_storeind_ptr GPR10 GPR12 ofs; + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); + expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; let va_ofs = Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin - expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg sz)); - expand_storeind_ptr GPR10 GPR12 ofs; + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); + expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; vararg_start_ofs := None end - | PExpand Pfreeframe (sz, ofs) -> + | Pfreeframe (sz, ofs) -> let sg = get_current_function_sig() in let extra_sz = if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in if n >= 8 then 0 else align 16 ((8 - n) * wordsize) end else 0 in - expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) (*| Pseqw(rd, rs1, rs2) -> (* emulate based on the fact that x == 0 iff x +*)| Pcvtl2w (rd, rs) -> assert Archi.ptr64; - emit (PArith (PArithRRI32 (Paddiw,rd, rs, Int.zero))) (* 32-bit sign extension *) - | PArith PArithR r -> (* Pcvtw2l *) + emit (Paddiw (rd, rs, Int.zero)) (* 32-bit sign extension *) + | Pcvtw2l (r) -> (* Pcvtw2l *) assert Archi.ptr64 (* no-operation because the 32-bit integer was kept sign extended already *) (* FIXME - is it really the case on the MPPA ? *) @@ -532,7 +533,7 @@ let expand_instruction instr = (* NOTE: Dwarf register maps for RV32G are not yet specified officially. This is just a placeholder. *) -let int_reg_to_dwarf = function +let int_reg_to_dwarf = let open Asmblock in function | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 @@ -547,10 +548,13 @@ let int_reg_to_dwarf = function | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 -let preg_to_dwarf = function +let breg_to_dwarf = let open Asmblock in function | IR r -> int_reg_to_dwarf r | FR r -> int_reg_to_dwarf r | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) + +let preg_to_dwarf = let open Asmblock in function + | BaR r -> breg_to_dwarf r | _ -> assert false let expand_function id fn = diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 15892818..8c3d1e8c 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -15,22 +15,28 @@ (* *) (* *********************************************************************) -Require Import Mach Asm Asmblockgen Machblockgen. +Require Import Integers. +Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import Errors. Local Open Scope error_monad_scope. +(** For OCaml code *) +Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n). +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + basic_to_instruction (storeind_ptr src base ofs). + Definition transf_program (p: Mach.program) : res Asm.program := let mbp := Machblockgen.transf_program p in do abp <- Asmblockgen.transf_program mbp; OK (Asm.transf_program abp). -Definition transf_function (f: Mach.function) : res function := +Definition transf_function (f: Mach.function) : res Asm.function := let mbf := Machblockgen.transf_function f in do abf <- Asmblockgen.transf_function mbf; OK (Asm.transf_function abf). -Definition transl_code (f: Mach.function) (l: Mach.code) : res (list instruction) := +Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) := let mbf := Machblockgen.transf_function f in let mbc := Machblockgen.trans_code l in do abc <- transl_blocks mbf mbc; diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 41ea06e4..819e11ae 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -40,7 +40,7 @@ module Target : TARGET = let print_label oc lbl = label oc (transl_label lbl) - let int_reg_name = function + let int_reg_name = let open Asmblock in function | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" @@ -62,16 +62,22 @@ module Target : TARGET = let ireg = ireg - let preg oc = function + let breg oc = let open Asmblock in function | IR r -> ireg oc r | FR r -> ireg oc r | RA -> output_string oc "$ra" - | _ -> assert false - let preg_annot = function + let breg_annot = let open Asmblock in function | IR r -> int_reg_name r | FR r -> int_reg_name r | RA -> "$ra" + + let preg oc = let open Asmblock in function + | BaR r -> breg oc r + | _ -> assert false + + let preg_annot = let open Asmblock in function + | BaR r -> breg_annot r | _ -> assert false (* Names of sections *) @@ -149,11 +155,11 @@ module Target : TARGET = *) (* Offset part of a load or store *) - let offset oc = function + let offset oc = let open Asmblock in function | Ofsimm n -> ptrofs oc n | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) - let icond_name = function + let icond_name = let open Asmblock in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" | ITlt -> "lt" @@ -171,7 +177,7 @@ module Target : TARGET = let icond oc c = fprintf oc "%s" (icond_name c) - let bcond_name = function + let bcond_name = let open Asmblock in function | BTwnez -> "wnez" | BTweqz -> "weqz" | BTwltz -> "wltz" @@ -188,7 +194,7 @@ module Target : TARGET = let bcond oc c = fprintf oc "%s" (bcond_name c) (* Printing of instructions *) - let print_ex_instruction oc = function + let print_instruction oc = function (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, ofs) -> assert false @@ -221,14 +227,9 @@ module Target : TARGET = | _ -> assert false end + | Pnop -> fprintf oc " nop\n;;\n" - (* Pseudo-instructions not generated by Asmgen *) - | Pclzll(rd, rs) -> - fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs - | Pstsud(rd, rs1, rs2) -> - fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - - let print_cf_instruction oc = function + (* Control flow instructions *) | Pget (rd, rs) -> fprintf oc " get %a = %a\n;;\n" ireg rd preg rs | Pset (rd, rs) -> @@ -244,7 +245,7 @@ module Target : TARGET = | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl - let print_ld_instruction oc = function + (* Load/Store instructions *) | Plb(rd, ra, ofs) -> fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plbu(rd, ra, ofs) -> @@ -257,8 +258,7 @@ module Target : TARGET = fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra - - let print_st_instruction oc = function + | Psb(rd, ra, ofs) -> fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psh(rd, ra, ofs) -> @@ -268,124 +268,108 @@ module Target : TARGET = | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd - let print_ar_r_instruction oc rd = (* function - | Pcvtw2l ->*) assert false + (* Arith R instructions *) + | Pcvtw2l(rd) -> assert false - let print_ar_rr_instruction oc rd rs = function - | Pmv | Pmvw2l -> + (* Arith RR instructions *) + | Pmv(rd, rs) | Pmvw2l(rd, rs) -> fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs - | Pcvtl2w -> assert false - | Pnegl -> assert Archi.ptr64; + | Pcvtl2w(rd, rs) -> assert false + | Pnegl(rd, rs) -> assert Archi.ptr64; fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs - | Pnegw -> + | Pnegw(rd, rs) -> fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs - | Pfnegd -> + | Pfnegd(rd, rs) -> fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd - let print_ar_ri32_instruction oc rd imm = (* function - | Pmake (rd, imm) -> *) + (* Arith RI32 instructions *) + | Pmake (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm - let print_ar_ri64_instruction oc rd imm = (* function - | Pmakel (rd, imm) -> *) + (* Arith RI64 instructions *) + | Pmakel (rd, imm) -> fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm - let print_ar_rrr_instruction oc rd rs1 rs2 = function - | Pcompw (it) -> + (* Arith RRR instructions *) + | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcompl (it) -> + | Pcompl (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 - | Paddw -> + | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psubw -> + | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 - | Pmulw -> + | Pmulw (rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pandw -> + | Pandw (rd, rs1, rs2) -> fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Porw -> + | Porw (rd, rs1, rs2) -> fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pxorw -> + | Pxorw (rd, rs1, rs2) -> fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psraw -> + | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psrlw -> + | Psrlw (rd, rs1, rs2) -> fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psllw -> + | Psllw (rd, rs1, rs2) -> fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Paddl -> assert Archi.ptr64; + | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psubl -> + | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 - | Pandl -> assert Archi.ptr64; + | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Porl -> assert Archi.ptr64; + | Porl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pxorl -> assert Archi.ptr64; + | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pmull -> + | Pmull (rd, rs1, rs2) -> fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Pslll -> + | Pslll (rd, rs1, rs2) -> fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psrll -> + | Psrll (rd, rs1, rs2) -> fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - | Psral -> + | Psral (rd, rs1, rs2) -> fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 - let print_ar_rri32_instruction oc rd rs imm = function - | Pcompiw (it) -> + (* Arith RRI32 instructions *) + | Pcompiw (it, rd, rs, imm) -> fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm - | Paddiw -> + | Paddiw (rd, rs, imm) -> fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pandiw -> + | Pandiw (rd, rs, imm) -> fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Poriw -> + | Poriw (rd, rs, imm) -> fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pxoriw -> + | Pxoriw (rd, rs, imm) -> fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psraiw -> + | Psraiw (rd, rs, imm) -> fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psrliw -> + | Psrliw (rd, rs, imm) -> fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pslliw -> + | Pslliw (rd, rs, imm) -> fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psllil -> + | Psllil (rd, rs, imm) -> fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psrlil -> + | Psrlil (rd, rs, imm) -> fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Psrail -> + | Psrail (rd, rs, imm) -> fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - let print_ar_rri64_instruction oc rd rs imm = function - | Pcompil (it) -> + (* Arith RRI64 instructions *) + | Pcompil (it, rd, rs, imm) -> fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm - | Paddil -> assert Archi.ptr64; + | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pandil -> assert Archi.ptr64; + | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Poril -> assert Archi.ptr64; + | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - | Pxoril -> assert Archi.ptr64; + | Pxoril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm - let print_ar_instruction oc = function - | PArithR(d) -> print_ar_r_instruction oc d - | PArithRR(ins, d, s) -> print_ar_rr_instruction oc d s ins - | PArithRI32(d, i) -> print_ar_ri32_instruction oc d i - | PArithRI64(d, i) -> print_ar_ri64_instruction oc d i - | PArithRRR(ins, d, s1, s2) -> print_ar_rrr_instruction oc d s1 s2 ins - | PArithRRI32(ins, d, s, i) -> print_ar_rri32_instruction oc d s i ins - | PArithRRI64(ins, d, s, i) -> print_ar_rri64_instruction oc d s i ins - - let print_instruction oc = function - | PExpand(i) -> print_ex_instruction oc i - | PControlFlow(i) -> print_cf_instruction oc i - | PLoad(i) -> print_ld_instruction oc i - | PStore(i) -> print_st_instruction oc i - | PArith(i) -> print_ar_instruction oc i - let get_section_names name = let (text, lit) = match C2C.atom_sections name with -- cgit From 3bedf90be891b20846aba183de479c5f25b630b1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Sep 2018 17:12:34 +0200 Subject: Rebase avec le commit qui fixe les tests + librairies --- mppa_k1c/Asm.v | 6 +++++- mppa_k1c/Asmexpand.ml | 12 ++++++------ mppa_k1c/TargetPrinter.ml | 4 ++++ 3 files changed, 15 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 14824b85..c142185c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -49,6 +49,10 @@ Inductive instruction : Type := -> builtin_res preg -> instruction (**r built-in function (pseudo) *) | 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 *) @@ -489,4 +493,4 @@ Proof. - intros. exists s1'. inv H0. split; auto. congruence. Qed. -End PRESERVATION. \ No newline at end of file +End PRESERVATION. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 81c3cf48..bb3baf31 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -419,12 +419,12 @@ let expand_builtin_inline name args res = let open Asmblock in | "__builtin_membar", [], _ -> () (* Vararg stuff *) - | "__builtin_va_start", [BA(IR a)], _ -> + | "__builtin_va_start", [BA(BaR (IR a))], _ -> expand_builtin_va_start a - | "__builtin_clzll", [BA(IR a)], BR(IR res) -> - emit (PExpand (Pclzll(res, a))) - | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> - emit (PExpand (Pstsud(res, a1, a2))) + | "__builtin_clzll", [BA(BaR (IR a))], BR(BaR (IR res)) -> + emit (Pclzll(res, a)) + | "__builtin_k1_stsud", [BA(BaR (IR a1)); BA(BaR (IR a2))], BR(BaR (IR res)) -> + emit (Pstsud(res, a1, a2)) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> expand_bswap16 res a1 @@ -511,7 +511,7 @@ let expand_instruction instr = | Pj_s(symb, sg) -> fixup_call sg; emit instr -*)| PExpand Pbuiltin (ef,args,res) -> +*)| Pbuiltin (ef,args,res) -> begin match ef with | EF_builtin (name,sg) -> expand_builtin_inline (camlstring_of_coqstring name) args res diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 819e11ae..ec579bf9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -229,6 +229,10 @@ module Target : TARGET = end | Pnop -> fprintf oc " nop\n;;\n" + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + (* Control flow instructions *) | Pget (rd, rs) -> fprintf oc " get %a = %a\n;;\n" ireg rd preg rs -- cgit From c673b6a5f66c931819fbcee8b7abcc974b0418f8 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 18 Sep 2018 18:26:18 +0200 Subject: premier jet Asmblockgenproof.return_address_offset --- mppa_k1c/Asmblockgenproof.v | 4 +- mppa_k1c/Asmblockgenproof0.v | 95 ++++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Asmgenproof.v | 7 ---- 3 files changed, 97 insertions(+), 9 deletions(-) create mode 100644 mppa_k1c/Asmblockgenproof0.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index de00218e..0476e76a 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -17,7 +17,7 @@ Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. (* Require Import Asmgen Asmgenproof0 Asmgenproof1. *) -Require Import Asmblockgen. +Require Import Asmblockgen Asmblockgenproof0. Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -1104,7 +1104,7 @@ Qed. *) Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - (fun a b c => False). + Asmblockgenproof0.return_address_offset. Axiom transf_program_correct: forward_simulation (Machblock.semantics return_address_offset prog) (Asmblock.semantics tprog). diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v new file mode 100644 index 00000000..374ae0d1 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof0.v @@ -0,0 +1,95 @@ +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. + +Module MB:=Machblock. +Module AB:=Asmblock. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + +(* ... skip ... *) + + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 32e8e8a8..f85445f2 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -42,13 +42,6 @@ Qed. (** Return Address Offset *) -Inductive code_tail: Z -> code -> code -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos i c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + 1) (i :: c1) c2. - Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. -- cgit From 191305d4cfc1416dd50080c93a7c3e16768934b4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 19 Sep 2018 12:09:36 +0200 Subject: proof sketch for Asmgenproof.return_address_exists ? --- mppa_k1c/Asmblockgenproof0.v | 4 ++++ mppa_k1c/Asmgenproof.v | 20 +++++++++++++++++--- 2 files changed, 21 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 374ae0d1..b1c71f42 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -93,3 +93,7 @@ Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : P transf_function f = OK tf -> transl_blocks f c = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Axiom 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. \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index f85445f2..94f3e531 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -16,7 +16,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. -Require Import Machblockgenproof Asmblockgenproof. +Require Import Machblockgenproof Asmblockgenproof0 Asmblockgenproof. Local Open Scope linking_scope. @@ -43,11 +43,25 @@ Qed. (** Return Address Offset *) Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. + Asmblockgenproof0.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. -Axiom return_address_exists: + +Lemma Mach_Machblock_tail: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists b, MB.exit b = Some (Machblock.MBcall sg ros) + /\ is_tail (b :: trans_code c) (MB.fn_code (Machblockgen.transf_function f)). +Admitted. + +Lemma return_address_exists: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> exists ra, return_address_offset f c ra. +Proof. + intros. + exploit Mach_Machblock_tail; eauto. + destruct 1 as [b [H1 H2]]. + eapply Asmblockgenproof0.return_address_exists; eauto. +Qed. + Section PRESERVATION. -- cgit From 2e2e6eec5f1e929db4d822024e301e1373bb7877 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 19 Sep 2018 17:40:38 +0200 Subject: return_address suite --- mppa_k1c/Asmblockgen.v | 18 +++++-- mppa_k1c/Asmblockgenproof.v | 10 ++-- mppa_k1c/Asmblockgenproof0.v | 114 +++++++++++++++++++++++++++++++++++++++++-- mppa_k1c/Asmgenproof.v | 12 ++--- 4 files changed, 137 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 79c28fe9..cc3038ca 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -872,20 +872,28 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) := end . -Definition transf_function (f: Machblock.function) := + + +Definition transl_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code); OK (mkfunction f.(Machblock.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b Pget GPR8 RA ::b storeind_ptr GPR8 SP f.(fn_retaddr_ofs) ::b lb)). -(* TODO TODO - move this check to Asm *) -(* Definition transf_function (f: Machblock.function) : res Asmblock.function := +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + +Definition transf_function (f: Machblock.function) : res Asmblock.function := do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) then Error (msg "code size exceeded") else OK tf. - *) Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 0476e76a..92d813b2 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -479,14 +479,17 @@ Proof. generalize (transf_function_no_overflow _ _ H0). omega. intros. apply Pregmap.gso; auto. Qed. +*) (** Existence of return addresses *) Lemma return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + 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 Asmgenproof0.return_address_exists; eauto. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. +Admitted. +(* - intros. exploit transl_instr_label; eauto. destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. - intros. monadInv H0. @@ -496,7 +499,8 @@ Proof. constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x). - exact transf_function_no_overflow. Qed. - *) +*) + (** * Proof of semantic preservation *) (** Semantic preservation is proved using simulation diagrams diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index b1c71f42..18e00601 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -60,7 +60,62 @@ Proof. eauto. Qed. -(* ... skip ... *) + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: size_blocks c >= 0. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_bounds_1: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + induction 1; intros; simpl. + generalize (size_blocks_pos c). omega. + generalize (size_positive bi). omega. +Qed. + + +Remark code_tail_bounds_2: + forall fn ofs i c, + code_tail ofs fn (i :: c) -> 0 <= ofs < size_blocks fn. +Admitted. +(* + assert (forall ofs fn c, code_tail ofs fn c -> + forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn). + induction 1; intros; simpl. + rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega. + rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega. + eauto. +Qed. +*) + +(* TODO: adapt this lemma -- needs Ptrofs.one -> size bi +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs Ptrofs.one)) fn c. +Proof. + intros. rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_one. + rewrite Ptrofs.unsigned_repr. apply code_tail_next with i; auto. + generalize (code_tail_bounds_2 _ _ _ _ H0). omega. +Qed. +*) (** Predictor for return addresses in generated Asm code. @@ -94,6 +149,59 @@ Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : P transl_blocks f c = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. -Axiom return_address_exists: +(* NB: this lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2, transl_blocks f c2 = OK tc2 -> + exists tc1, transl_blocks f c1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & A & B). + exists tc1; split. auto. + eapply is_tail_trans; eauto with coqlib. +Qed. + + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc, transl_blocks f (Machblock.fn_code f) = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + +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. \ No newline at end of file + 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 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & TR2 & TL2). + unfold return_address_offset. + (* exploit code_tail_next_int; eauto.*) +Admitted. + +(* +Opaque transl_instr. + monadInv TR2. + assert (TL3: is_tail x (fn_code tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with tc2; auto. + eapply transl_instr_tail; eauto. } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds_1; eauto. + apply transf_function_len in TF. omega. ++ exists Ptrofs.zero; red; intros. congruence. +Qed. +*) +End RETADDR_EXISTS. \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 94f3e531..980b9576 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -16,7 +16,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. -Require Import Machblockgenproof Asmblockgenproof0 Asmblockgenproof. +Require Import Machblockgenproof Asmblockgenproof. Local Open Scope linking_scope. @@ -43,13 +43,13 @@ Qed. (** Return Address Offset *) Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - Asmblockgenproof0.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. + Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. Lemma Mach_Machblock_tail: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists b, MB.exit b = Some (Machblock.MBcall sg ros) - /\ is_tail (b :: trans_code c) (MB.fn_code (Machblockgen.transf_function f)). + exists b, Machblock.exit b = Some (Machblock.MBcall sg ros) + /\ is_tail (b :: trans_code c) (Machblock.fn_code (Machblockgen.transf_function f)). Admitted. Lemma return_address_exists: @@ -59,8 +59,8 @@ Proof. intros. exploit Mach_Machblock_tail; eauto. destruct 1 as [b [H1 H2]]. - eapply Asmblockgenproof0.return_address_exists; eauto. -Qed. + eapply Asmblockgenproof.return_address_exists; eauto. +Admitted. Section PRESERVATION. -- cgit From 455736d0fff5f4b9636e8433519fe18ebb3c196d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 20 Sep 2018 10:03:57 +0200 Subject: avancement return_address --- mppa_k1c/Asmblockgenproof0.v | 109 +++++++++++++++++++++++++------------------ 1 file changed, 64 insertions(+), 45 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 18e00601..2fd6e768 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -74,50 +74,57 @@ Proof. omega. Qed. -Lemma size_blocks_pos c: size_blocks c >= 0. +Lemma size_blocks_pos c: 0 <= size_blocks c. Proof. induction c as [| a l ]; simpl; try omega. generalize (size_positive a); omega. Qed. -Remark code_tail_bounds_1: +Remark code_tail_positive: forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. + code_tail ofs fn c -> 0 <= ofs. Proof. induction 1; intros; simpl. - generalize (size_blocks_pos c). omega. - generalize (size_positive bi). omega. + - omega. + - generalize (size_positive bi). omega. Qed. +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. -Remark code_tail_bounds_2: - forall fn ofs i c, - code_tail ofs fn (i :: c) -> 0 <= ofs < size_blocks fn. -Admitted. -(* - assert (forall ofs fn c, code_tail ofs fn c -> - forall i c', c = i :: c' -> 0 <= ofs < list_length_z fn). - induction 1; intros; simpl. - rewrite H. rewrite list_length_z_cons. generalize (list_length_z_pos c'). omega. - rewrite list_length_z_cons. generalize (IHcode_tail _ _ H0). omega. - eauto. +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. Qed. -*) -(* TODO: adapt this lemma -- needs Ptrofs.one -> size bi +Local Hint Resolve code_tail_next. + +(* is it useful ? Lemma code_tail_next_int: forall fn ofs bi c, size_blocks fn <= Ptrofs.max_unsigned -> code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs Ptrofs.one)) fn c. + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. Proof. - intros. rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_one. - rewrite Ptrofs.unsigned_repr. apply code_tail_next with i; auto. - generalize (code_tail_bounds_2 _ _ _ _ H0). omega. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. Qed. *) - (** Predictor for return addresses in generated Asm code. The [return_address_offset] predicate defined here is used in the @@ -149,13 +156,21 @@ Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : P transl_blocks f c = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. -(* NB: this lemma should go into [Coqlib.v] *) +(* NB: these two lemma should go into [Coqlib.v] *) Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). Proof. induction l1; simpl; auto with coqlib. Qed. Hint Resolve is_tail_app: coqlib. +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + Lemma transl_blocks_tail: forall f c1 c2, is_tail c1 c2 -> forall tc2, transl_blocks f c2 = OK tc2 -> @@ -168,6 +183,12 @@ Proof. eapply is_tail_trans; eauto with coqlib. Qed. +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. Section RETADDR_EXISTS. @@ -178,30 +199,28 @@ Hypothesis transf_function_inv: Hypothesis transf_function_len: forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + +(* NB: the hypothesis on [b] is not needed in the proof ! + It is strange, no ? + *) 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 (* 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. destruct (transf_function f) as [tf|] eqn:TF. -+ exploit transf_function_inv; eauto. intros (tc1 & TR1 & TL1). - exploit transl_blocks_tail; eauto. intros (tc2 & TR2 & TL2). - unfold return_address_offset. - (* exploit code_tail_next_int; eauto.*) -Admitted. - -(* -Opaque transl_instr. - monadInv TR2. - assert (TL3: is_tail x (fn_code tf)). - { apply is_tail_trans with tc1; auto. - apply is_tail_trans with tc2; auto. - eapply transl_instr_tail; eauto. } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds_1; eauto. - apply transf_function_len in TF. omega. -+ exists Ptrofs.zero; red; intros. congruence. + + exploit transf_function_inv; eauto. intros (tc1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & TR2 & TL2). + unfold return_address_offset. + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; eauto with coqlib. } + exploit is_tail_code_tail; eauto. + intros [ofs CT]. + exists (Ptrofs.repr ofs). intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. Qed. -*) + End RETADDR_EXISTS. \ No newline at end of file -- cgit From 437e499c046fbf5f527c0a8442982382d02c6871 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 20 Sep 2018 18:38:08 +0200 Subject: return_address_exists -> done --- mppa_k1c/Asmblockgenproof.v | 27 +++++++------- mppa_k1c/Asmblockgenproof0.v | 4 +-- mppa_k1c/Asmgenproof.v | 86 ++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 92 insertions(+), 25 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 92d813b2..7288716e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -63,14 +63,15 @@ Qed. *) (** * Properties of control flow *) -(* Lemma transf_function_no_overflow: +Lemma transf_function_no_overflow: forall f tf, - transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. omega. Qed. +(* Lemma exec_straight_exec: forall fb f c ep tf tc c' rs m rs' m', transl_code_at_pc ge (rs PC) fb f c ep tf tc -> @@ -483,23 +484,19 @@ 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) -> + 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. -Admitted. -(* -- intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. - rewrite transl_code'_transl_code in EQ0. - exists x; exists true; split; auto. unfold fn_code. - constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x). -- exact transf_function_no_overflow. + - intros f0 tf H0. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + monadInv EQ. simpl. + eapply ex_intro; constructor 1; eauto with coqlib. + - exact transf_function_no_overflow. Qed. -*) (** * Proof of semantic preservation *) diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 2fd6e768..bd4266ce 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -200,9 +200,7 @@ Hypothesis transf_function_len: forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. -(* NB: the hypothesis on [b] is not needed in the proof ! - It is strange, no ? - *) +(* 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. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 980b9576..74be571d 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -46,11 +46,83 @@ Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. -Lemma Mach_Machblock_tail: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists b, Machblock.exit b = Some (Machblock.MBcall sg ros) - /\ is_tail (b :: trans_code c) (Machblock.fn_code (Machblockgen.transf_function f)). -Admitted. +(* TODO: put this proof in Machblocgen ? (it is specific to Machblocgen) *) +Lemma trans_code_monotonic c i b l: + trans_code c = b::l -> + exists l', exists b', trans_code (i::c) = l' ++ (b'::l). +Proof. + destruct c as [|i' c]. { rewrite trans_code_equation; intros; congruence. } + destruct (get_code_nature (i :: i':: c)) eqn:GCNIC. + - apply get_code_nature_empty in GCNIC. discriminate. + - (* i=label *) + destruct i; try discriminate. + rewrite! trans_code_equation; + remember (to_bblock (Mlabel l0 :: i' :: c)) as b0. + destruct b0 as [b0 c0]. + exploit to_bblock_label; eauto. + intros (H1 & H2). rewrite H2; simpl; clear H2. + intros H2; inversion H2; subst. + exists nil; simpl; eauto. + - (*i=basic *) + rewrite! trans_code_equation; destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + destruct (cn_eqdec (get_code_nature (i':: c)) IsLabel). + + (* i'=label *) remember (to_bblock (i :: i' :: c)) as b1. + destruct b1 as [b1 c1]. + assert (X: c1 = i'::c). + { generalize Heqb1; clear Heqb1. + unfold to_bblock. + erewrite to_bblock_header_noLabel; try congruence. + destruct i'; try discriminate. + destruct i; try discriminate; simpl; + intro X; inversion X; auto. + } + subst c1. + rewrite !trans_code_equation. intro H1; rewrite H1. + exists (b1 :: nil). simpl; eauto. + + (* i'<>label *) remember (to_bblock (i :: i' :: c)) as b1. + destruct b1 as [b1 c1]. + remember (to_bblock (i' :: c)) as b2. + destruct b2 as [b2 c2]. + intro H1; assert (X: c1=c2). + { generalize Heqb1, Heqb2; clear Heqb1 Heqb2. + unfold to_bblock. + erewrite to_bblock_header_noLabel; try congruence. + destruct i'; simpl in * |- ; try congruence; + destruct i; try discriminate; simpl; + try (destruct (to_bblock_body c) as [xx yy], (to_bblock_exit yy); + intros X1 X2; inversion X1; inversion X2; auto). + } + subst; inversion H1. + exists nil; simpl; eauto. + - (* i=cfi *) + remember (to_cfi i) as cfi. + intros H. destruct cfi. + + erewrite trans_code_cfi; eauto. + rewrite H. + refine (ex_intro _ (_::nil) _). simpl; eauto. + + destruct i; simpl in * |-; try congruence. +Qed. + +Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> + exists b, (* Machblock.exit b = Some (Machblock.MBcall sg ros) /\ *) + is_tail (b :: trans_code c) (trans_code c2). +Proof. + intro H; induction 1. + - intros; subst. + rewrite (trans_code_equation (Mcall sg ros :: c)). + simpl. + eapply ex_intro; eauto with coqlib. + - intros; exploit IHis_tail; eauto. clear IHis_tail. + intros (b & Hb). + + inversion Hb; clear Hb. + * exploit (trans_code_monotonic c2 i); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eauto with coqlib. + * exploit (trans_code_monotonic c2 i); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eapply ex_intro. + eapply is_tail_trans; eauto with coqlib. +Qed. Lemma return_address_exists: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> @@ -58,9 +130,9 @@ Lemma return_address_exists: Proof. intros. exploit Mach_Machblock_tail; eauto. - destruct 1 as [b [H1 H2]]. + destruct 1. eapply Asmblockgenproof.return_address_exists; eauto. -Admitted. +Qed. Section PRESERVATION. -- cgit From bcb6ec6c7a99deb8f211b6a9ba3c6fe7565d3fcb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 21 Sep 2018 16:39:47 +0200 Subject: MB2AB - Trois premières parties du lock-step MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgenproof.v | 37 +++--- mppa_k1c/Asmblockgenproof0.v | 302 ++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 322 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 7288716e..87b15c39 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -19,6 +19,9 @@ Require Import Op Locations Machblock Conventions Asmblock. (* Require Import Asmgen Asmgenproof0 Asmgenproof1. *) Require Import Asmblockgen Asmblockgenproof0. +Module MB := Machblock. +Module AB := Asmblock. + Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -36,7 +39,7 @@ Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -(* Lemma symbols_preserved: +Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof (Genv.find_symbol_match TRANSF). @@ -44,6 +47,7 @@ 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 -> @@ -516,14 +520,6 @@ Qed. - Mach register values and Asm register values agree. *) -Definition match_stack : Machblock.genv -> list stackframe -> Prop := (fun x y => False). - -Definition transl_code_at_pc : - Machblock.genv -> val -> block -> Machblock.function -> Machblock.code -> bool -> function -> code -> Prop - := (fun a b c d e f g h => False). - -Definition agree : Mach.regset -> val -> regset -> Prop := (fun a b c => False). - Inductive match_states: Machblock.state -> Asmblock.state -> Prop := | match_states_intro: forall s fb sp c ep ms m m' rs f tf tc @@ -1072,10 +1068,11 @@ Local Transparent destroyed_at_function_entry. rewrite <- ATPC in H5. econstructor; eauto. congruence. Qed. +*) Lemma transf_initial_states: - forall st1, Mach.initial_state prog st1 -> - exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. + 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. @@ -1087,7 +1084,7 @@ Proof. constructor. apply Mem.extends_refl. split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Regmap.gi. auto. + intros. rewrite Mach.Regmap.gi. auto. unfold Genv.symbol_address. rewrite (match_program_main TRANSF). rewrite symbols_preserved. @@ -1096,19 +1093,27 @@ Qed. Lemma transf_final_states: forall st1 st2 r, - match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state 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. -Axiom transf_program_correct: - forward_simulation (Machblock.semantics return_address_offset prog) (Asmblock.semantics tprog). +Axiom TODO: False. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (AB.semantics tprog). +Proof. + eapply forward_simulation_step. + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - destruct TODO. +Qed. (* Theorem transf_program_correct: diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index bd4266ce..52ba9ca2 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -17,6 +17,245 @@ Require Import Asmblockgen. Module MB:=Machblock. 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. + +(* 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. + + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +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. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <-- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +(* Lemma agree_nextinstr: + forall ms sp rs, + agree ms sp rs -> agree ms sp (nextinstr rs). +Proof. + intros. unfold nextinstr. apply agree_set_other. auto. auto. +Qed. + *) + +(* Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + *) + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +(* Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree 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 Mach.undef_regs_other; 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_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 -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + *) + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <-- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + + (* inspired from Mach *) Lemma find_label_tail: @@ -221,4 +460,65 @@ Proof. + exists Ptrofs.zero; red; intros. congruence. Qed. -End RETADDR_EXISTS. \ No newline at end of file +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], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. \ No newline at end of file -- cgit From 1f46c2ef4d9080357f37ccb6aa9847ecb8def582 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 21 Sep 2018 17:22:01 +0200 Subject: MB2AB - changement du lock-step en star, cas du Returnstate fait --- mppa_k1c/Asmblockgenproof.v | 37 +++++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 87b15c39..79a51d16 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -663,12 +663,6 @@ Qed. *) So, the following integer measure will suffice to rule out the unwanted behaviour. *) -Definition measure (s: Mach.state) : nat := - match s with - | Mach.State _ _ _ _ _ _ => 0%nat - | Mach.Callstate _ _ _ _ => 0%nat - | Mach.Returnstate _ _ _ => 1%nat - end. (* Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. Proof. @@ -1070,6 +1064,31 @@ Local Transparent destroyed_at_function_entry. Qed. *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +Axiom TODO: False. + +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. + - destruct TODO. + - destruct TODO. + - destruct TODO. + - inv MS. inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Admitted. + Lemma transf_initial_states: forall st1, MB.initial_state prog st1 -> exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. @@ -1103,16 +1122,14 @@ Qed. Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := Asmblockgenproof0.return_address_offset. -Axiom TODO: False. - Theorem transf_program_correct: forward_simulation (MB.semantics return_address_offset prog) (AB.semantics tprog). Proof. - eapply forward_simulation_step. + eapply forward_simulation_star with (measure := measure). - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - - destruct TODO. + - exact step_simulation. Qed. (* -- cgit From 4d5a6d22a6e10c30bae0b19fb6059a5c6e8de2fa Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 24 Sep 2018 12:48:02 +0200 Subject: relecture --- mppa_k1c/Asmblockgenproof.v | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 79a51d16..c2a609c9 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1087,7 +1087,7 @@ Proof. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. -Admitted. +Qed. Lemma transf_initial_states: forall st1, MB.initial_state prog st1 -> @@ -1132,15 +1132,4 @@ Proof. - exact step_simulation. Qed. -(* -Theorem transf_program_correct: - forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact step_simulation. -Qed. *) - End PRESERVATION. -- cgit From 4cc8ba6663f9e41ac45a1a2e0fbb7ef360342162 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 24 Sep 2018 12:49:39 +0200 Subject: one step toward "bundle_step" --- mppa_k1c/Asmblock.v | 61 +++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 55 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 58cc0f2c..293752f8 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1105,15 +1105,15 @@ Inductive state: Type := * Perhaps there is a way to avoid that ? *) -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: +Inductive stepin: option bblock -> state -> trace -> state -> Prop := + | exec_stepin_internal: forall b ofs f bi rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> exec_bblock f bi rs m = Next rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_builtin: + stepin (Some bi) (State rs m) E0 (State rs' m') + | exec_stepin_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' bi, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> @@ -1125,15 +1125,64 @@ Inductive step: state -> trace -> state -> Prop := (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs#GPR31 <-- Vundef))) -> - step (State rs m) t (State rs' m') - | exec_step_external: + stepin (Some bi) (State rs m) t (State rs' m') + | exec_stepin_external: forall b ef args res rs m t rs' m', rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> rs' = (update_pregs rs (set_pair (loc_external_result (ef_sig ef) ) res rs))#PC <-- (rs RA) -> + stepin None (State rs m) t (State rs' m') + . + +Definition step (s:state) (t:trace) (s':state): Prop := exists obi, stepin obi s t s'. + +(* original constructors *) +Lemma exec_step_internal b ofs f bi rs m rs' m': + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> + exec_bblock f bi rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m'). +Proof. + intros; eexists. eapply exec_stepin_internal; eauto. +Qed. + +Lemma exec_step_builtin b ofs f ef args res rs m vargs t vres rs' m' bi: + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextblock bi + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#GPR31 <-- Vundef))) -> step (State rs m) t (State rs' m'). +Proof. + intros; eexists. eapply exec_stepin_builtin; eauto. +Qed. + +Lemma exec_step_external b ef args res rs m t rs' m': + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (update_pregs rs (set_pair (loc_external_result (ef_sig ef) ) res rs))#PC <-- (rs RA) -> + step (State rs m) t (State rs' m') + . +Proof. + intros; eexists. eapply exec_stepin_external; eauto. +Qed. + + +(* juste pour essayer *) +Parameter is_bundle: bblock -> Prop. + +Definition bundle_step (s:state) (t:trace) (s':state): Prop := + exists obi, stepin obi s t s' /\ forall bi, obi = Some bi -> is_bundle bi. End RELSEM. -- cgit From 7f82b7c266e9b5673c3e088c46aab7cc2bd4f3f0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 24 Sep 2018 14:39:32 +0200 Subject: a few stubs for bundling --- mppa_k1c/Asmblock.v | 194 --------------------------------------- mppa_k1c/Asmbundle.v | 216 ++++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Asmbundling.v | 23 +++++ mppa_k1c/Asmbundlingproof.v | 95 +++++++++++++++++++ 4 files changed, 334 insertions(+), 194 deletions(-) create mode 100644 mppa_k1c/Asmbundle.v create mode 100644 mppa_k1c/Asmbundling.v create mode 100644 mppa_k1c/Asmbundlingproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 293752f8..ba14c451 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1178,12 +1178,6 @@ Proof. Qed. -(* juste pour essayer *) -Parameter is_bundle: bblock -> Prop. - -Definition bundle_step (s:state) (t:trace) (s':state): Prop := - exists obi, stepin obi s t s' /\ forall bi, obi = Some bi -> is_bundle bi. - End RELSEM. (** Execution of whole programs. *) @@ -1282,191 +1276,3 @@ Ltac Equalities := inv H; inv H0. congruence. Qed. *) - - -(* - -(** * Instruction dependencies, definition of a bundle - -NOTE: this would be better to do this in an other file, e.g. Asmbundle ? - -*) - -(** NOTE: in all of these dependencies definitions, we do *not* consider PC. - PC dependencies are fullfilled by the above separation in bblocks - *) - -(* (writereg i rd) holds if an instruction writes to a single register rd *) -Inductive writereg: instruction -> preg -> Prop := - | writereg_set: forall rd rs, writereg (Pset rd rs) rd - | writereg_get: forall rd rs, writereg (Pget rd rs) rd - | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd - | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd - | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd - | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd - | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd - | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd - | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd - | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd - . - -(* (nowrite i) holds if an instruction doesn't write to any register *) -Inductive nowrite: instruction -> Prop := - | nowrite_ret: nowrite Pret - | nowrite_call: forall l, nowrite (Pcall l) - | nowrite_goto: forall l, nowrite (Pgoto l) - | nowrite_jl: forall l, nowrite (Pj_l l) - | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) - | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) - | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) - | nowrite_label: forall l, nowrite (Plabel l) - . - -(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) -Inductive readregs: instruction -> list preg -> Prop := - | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) - | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) - | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) - | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) - | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) - | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) - | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) - | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) - | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) - | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) - . - -(* (noread i) holds if an instruction doesn't read any register *) -Inductive noread: instruction -> Prop := - | noread_ret: noread Pret - | noread_call: forall l, noread (Pcall l) - | noread_goto: forall l, noread (Pgoto l) - | noread_jl: forall l, noread (Pj_l l) - | noread_arith_r: forall i rd, noread (PArithR i rd) - | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) - | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) - | noread_label: forall l, noread (Plabel l) - . - -(* (wawfree i i') holds if i::i' has no WAW dependency *) -Inductive wawfree: instruction -> instruction -> Prop := - | wawfree_write: forall i rs i' rs', - writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' - | wawfree_free1: forall i i', - nowrite i -> wawfree i i' - | wawfree_free2: forall i i', - nowrite i' -> wawfree i i' - . - -(* (rawfree i i') holds if i::i' has no RAW dependency *) -Inductive rawfree: instruction -> instruction -> Prop := - | rawfree_single: forall i rd i' rs, - writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' - | rawfree_double: forall i rd i' rs rs', - writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' - | rawfree_free1: forall i i', - nowrite i -> rawfree i i' - | rawfree_free2: forall i i', - noread i' -> rawfree i i' - . - -(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) -Inductive depfree: instruction -> instruction -> Prop := - | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. - -(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) -Inductive depfreelist: instruction -> list instruction -> Prop := - | depfreelist_nil: forall i, - depfreelist i nil - | depfreelist_cons: forall i i' l, - depfreelist i l -> depfree i i' -> depfreelist i (i'::l) - . - -(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) -Inductive depfreeall: list instruction -> Prop := - | depfreeall_nil: - depfreeall nil - | depfreeall_cons: forall i l, - depfreeall l -> depfreelist i l -> depfreeall (i::l) - . - -(** NOTE: we do not verify the resource constraints of the bundles, - since not meeting them causes a failure when invoking the assembler *) - -(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) -Inductive wf_bundle: bblock -> Prop := - | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. - -Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. - -Record bundle := mk_bundle { - bd_block: bblock; - bd_correct: wf_bundle bd_block -}. - -Definition bundles := list bundle. - -Definition unbundlize (lb: list bundle) := map bd_block lb. -Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). - -Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. -Proof. - intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. -Qed. - -(** Some theorems on bundles construction *) -Lemma bundle_empty_correct: wf_bundle empty_bblock. -Proof. - constructor. auto. -Qed. - -Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. - -(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) - -Definition single_inst_block (i: instruction) := acc_block i empty_bblock. - -Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). -Proof. - intros i. unfold single_inst_block. unfold acc_block. destruct i. - all: simpl; constructor; simpl; auto. -Qed. - -Definition bundlize_inst (i: instruction) := - {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. - -Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. -Proof. - induction c as [|i c]; simpl; auto. - rewrite IHc. destruct i; simpl; auto. -Qed. - -Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). - -Fixpoint bundlize (lb: list bblock) := - match lb with - | nil => nil - | b :: lb => split_bblock b ++ bundlize lb - end. - -Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. -Proof. - intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. -Qed. - -Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. -Proof. - induction lb as [|b lb]; simpl; auto. - rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. -Qed. - -Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. -Proof. - intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. -Qed. - -Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. -Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -*) \ No newline at end of file diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v new file mode 100644 index 00000000..5ded4c65 --- /dev/null +++ b/mppa_k1c/Asmbundle.v @@ -0,0 +1,216 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Export Asmblock. + +Section RELSEM. + +Variable ge: genv. + +(* FIXME: STUB *) +Definition is_bundle (b:bblock):=True. + +Definition bundle_step (s:state) (t:trace) (s':state): Prop := + exists obi, stepin ge obi s t s' /\ forall bi, obi = Some bi -> is_bundle bi. + +End RELSEM. + +Definition bundle_semantics (p: program) := + Semantics bundle_step (initial_state p) final_state (Genv.globalenv p). + + + +(* + +(** * Instruction dependencies, definition of a bundle + +*) + +(** NOTE: in all of these dependencies definitions, we do *not* consider PC. + PC dependencies are fullfilled by the above separation in bblocks + *) + +(* (writereg i rd) holds if an instruction writes to a single register rd *) +Inductive writereg: instruction -> preg -> Prop := + | writereg_set: forall rd rs, writereg (Pset rd rs) rd + | writereg_get: forall rd rs, writereg (Pget rd rs) rd + | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd + | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd + | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd + | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd + | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd + | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd + | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd + | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd + . + +(* (nowrite i) holds if an instruction doesn't write to any register *) +Inductive nowrite: instruction -> Prop := + | nowrite_ret: nowrite Pret + | nowrite_call: forall l, nowrite (Pcall l) + | nowrite_goto: forall l, nowrite (Pgoto l) + | nowrite_jl: forall l, nowrite (Pj_l l) + | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) + | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) + | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) + | nowrite_label: forall l, nowrite (Plabel l) + . + +(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) +Inductive readregs: instruction -> list preg -> Prop := + | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) + | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) + | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) + | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) + | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) + | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) + | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) + | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) + | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) + | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) + . + +(* (noread i) holds if an instruction doesn't read any register *) +Inductive noread: instruction -> Prop := + | noread_ret: noread Pret + | noread_call: forall l, noread (Pcall l) + | noread_goto: forall l, noread (Pgoto l) + | noread_jl: forall l, noread (Pj_l l) + | noread_arith_r: forall i rd, noread (PArithR i rd) + | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) + | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) + | noread_label: forall l, noread (Plabel l) + . + +(* (wawfree i i') holds if i::i' has no WAW dependency *) +Inductive wawfree: instruction -> instruction -> Prop := + | wawfree_write: forall i rs i' rs', + writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' + | wawfree_free1: forall i i', + nowrite i -> wawfree i i' + | wawfree_free2: forall i i', + nowrite i' -> wawfree i i' + . + +(* (rawfree i i') holds if i::i' has no RAW dependency *) +Inductive rawfree: instruction -> instruction -> Prop := + | rawfree_single: forall i rd i' rs, + writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' + | rawfree_double: forall i rd i' rs rs', + writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' + | rawfree_free1: forall i i', + nowrite i -> rawfree i i' + | rawfree_free2: forall i i', + noread i' -> rawfree i i' + . + +(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) +Inductive depfree: instruction -> instruction -> Prop := + | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. + +(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) +Inductive depfreelist: instruction -> list instruction -> Prop := + | depfreelist_nil: forall i, + depfreelist i nil + | depfreelist_cons: forall i i' l, + depfreelist i l -> depfree i i' -> depfreelist i (i'::l) + . + +(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) +Inductive depfreeall: list instruction -> Prop := + | depfreeall_nil: + depfreeall nil + | depfreeall_cons: forall i l, + depfreeall l -> depfreelist i l -> depfreeall (i::l) + . + +(** NOTE: we do not verify the resource constraints of the bundles, + since not meeting them causes a failure when invoking the assembler *) + +(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) +Inductive wf_bundle: bblock -> Prop := + | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. + +Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. + +Record bundle := mk_bundle { + bd_block: bblock; + bd_correct: wf_bundle bd_block +}. + +Definition bundles := list bundle. + +Definition unbundlize (lb: list bundle) := map bd_block lb. +Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). + +Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. +Proof. + intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. +Qed. + +(** Some theorems on bundles construction *) +Lemma bundle_empty_correct: wf_bundle empty_bblock. +Proof. + constructor. auto. +Qed. + +Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. + +(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) + +Definition single_inst_block (i: instruction) := acc_block i empty_bblock. + +Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). +Proof. + intros i. unfold single_inst_block. unfold acc_block. destruct i. + all: simpl; constructor; simpl; auto. +Qed. + +Definition bundlize_inst (i: instruction) := + {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. + +Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. +Proof. + induction c as [|i c]; simpl; auto. + rewrite IHc. destruct i; simpl; auto. +Qed. + +Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). + +Fixpoint bundlize (lb: list bblock) := + match lb with + | nil => nil + | b :: lb => split_bblock b ++ bundlize lb + end. + +Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. +Proof. + intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. +Qed. + +Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. +Proof. + induction lb as [|b lb]; simpl; auto. + rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. +Qed. + +Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. +Proof. + intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. +Qed. + +Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. +Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +*) \ No newline at end of file diff --git a/mppa_k1c/Asmbundling.v b/mppa_k1c/Asmbundling.v new file mode 100644 index 00000000..a7c1b81e --- /dev/null +++ b/mppa_k1c/Asmbundling.v @@ -0,0 +1,23 @@ +Require Archi. +Require Import Coqlib Errors. +Require Import AST Integers Floats Memdata. +Require Import Op Locations Asmblock Asmbundle. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(* FIXME: STUB *) + +Definition transl_blocks (lb: Asmblock.bblocks): res Asmblock.bblocks := + OK lb +. + +Definition transf_function (f: Asmblock.function) := + do lb <- transl_blocks f.(Asmblock.fn_blocks); + OK (mkfunction f.(Asmblock.fn_sig) lb). + +Definition transf_fundef (f: Asmblock.fundef) : res Asmblock.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Asmblock.program) : res Asmblock.program := + transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmbundlingproof.v b/mppa_k1c/Asmbundlingproof.v new file mode 100644 index 00000000..33066786 --- /dev/null +++ b/mppa_k1c/Asmbundlingproof.v @@ -0,0 +1,95 @@ + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Conventions Asmblock. +Require Import Asmbundle Asmbundling. + +Definition match_prog (p: program) (tp: 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: Asmblock.program. +Variable tprog: Asmblock.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. inv H0; auto. +Qed. + +(* Aargh: harder to prove than expected ! *) +Lemma stepi_simulation obi s1 t s2: stepin ge obi s1 t s2 -> stepin tge obi s1 t s2. +Admitted. + + +(* FIXME: generalize to forward_simulation_plus *) +Theorem step_simulation s1 t s2: step ge s1 t s2 -> bundle_step tge s1 t s2. +Proof. + intros (obi & H). + exists obi. constructor 1. + - apply stepi_simulation; auto. + - unfold is_bundle; auto. +Qed. + + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> exists st2, initial_state tprog st2 /\ st1 = st2. +Proof. + intros st1 H. + inversion H. unfold ge0 in *. + econstructor 1; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero). + econstructor; eauto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite! symbols_preserved. + auto. +Qed. + +Local Hint Resolve step_simulation. + +Theorem transf_program_correct: + forward_simulation (semantics prog) (bundle_semantics tprog). +Proof. + (* FIXME: in general forward_simulation_plus *) + eapply forward_simulation_step. + - apply senv_preserved. + - eexact transf_initial_states. + - intros; subst; simpl; auto. + - intros; subst; simpl in * |- *; eauto. +Qed. + +End PRESERVATION. -- cgit From d872a6aea877e642c31ccb671d6ec1eb7501b57b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 24 Sep 2018 18:46:49 +0200 Subject: Some definitions in Asmbundle --- mppa_k1c/Asmbundle.v | 98 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v index 5ded4c65..14a2ea7e 100644 --- a/mppa_k1c/Asmbundle.v +++ b/mppa_k1c/Asmbundle.v @@ -12,11 +12,109 @@ Require Import Locations. Require Stacklayout. Require Import Conventions. Require Export Asmblock. +Require Import ListSet. Section RELSEM. Variable ge: genv. +(** List of all registers, to use for Pbuiltin dependencies *) +Definition all_gpregs := + GPR0 :: GPR1 :: GPR2 :: GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: + GPR10 :: GPR11 :: GPR12 :: GPR13 :: GPR14 :: GPR15 :: GPR16 :: GPR17 :: GPR18 :: GPR19 :: + GPR20 :: GPR21 :: GPR22 :: GPR23 :: GPR24 :: GPR25 :: GPR26 :: GPR27 :: GPR28 :: GPR29 :: + GPR30 :: GPR31 :: GPR32 :: GPR33 :: GPR34 :: GPR35 :: GPR36 :: GPR37 :: GPR38 :: GPR39 :: + GPR40 :: GPR41 :: GPR42 :: GPR43 :: GPR44 :: GPR45 :: GPR46 :: GPR47 :: GPR48 :: GPR49 :: + GPR50 :: GPR51 :: GPR52 :: GPR53 :: GPR54 :: GPR55 :: GPR56 :: GPR57 :: GPR58 :: GPR59 :: + GPR60 :: GPR61 :: GPR62 :: GPR63 :: nil. + +Fact all_gpregs_complete : forall gpr, List.In gpr all_gpregs. +Proof. + intros. destruct gpr; simpl. + all: repeat ((try (left; reflexivity)); right). +Qed. + +Definition all_bregs := (map IR all_gpregs) ++ (map FR all_gpregs) ++ (RA::nil). + +Fact all_bregs_complete : forall br, List.In br all_bregs. +Proof. + intros. destruct br. + - unfold all_bregs. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. + - unfold all_bregs. apply in_app_iff. right. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. + - unfold all_bregs. repeat (apply in_app_iff; right). simpl. left; auto. +Qed. + +Definition readregs (i: instruction) : list breg := + match i with + (* Control instructions *) + | Pset rd rs => IR rs::nil + | Pget rd rs => rs::nil + | Pcb bt r l => IR r::nil + | Pcbu bt r l => IR r::nil + | Pret => RA::nil + (* Load and store *) + | PLoadRRO i rd ra o => IR ra :: nil + | PStoreRRO i rs ra o => IR rs :: IR ra :: nil + (* Arith *) + | PArithRR i rd rs => IR rs :: nil + | PArithRRR i rd rs1 rs2 => IR rs1 :: IR rs2 :: nil + | PArithRRI32 i rd rs imm => IR rs :: nil + | PArithRRI64 i rd rs imm => IR rs :: nil + (* Alloc and freeframe and builtins : implemented in OCaml, we know nothing about them *) + | Pallocframe _ _ | Pfreeframe _ _ | Pbuiltin _ _ _ => all_bregs + (* Instructions that do not read *) + | Pnop | Pcall _ | Pgoto _ | Pj_l _ | PArithR _ _ | PArithRI32 _ _ _ | PArithRI64 _ _ _ => nil + end. + +Definition writeregs (i: instruction): list breg := + match i with + (* Control instructions *) + | Pset rd rs => rd::nil + | Pget rd rs => IR rd::nil + | Pcall s => RA::nil + (* Load *) + | PLoadRRO i rd ra o => IR rd::nil + (* Arith *) + | PArithR i rd => IR rd::nil + | PArithRR i rd rs => IR rd::nil + | PArithRI32 i rd imm => IR rd::nil + | PArithRI64 i rd imm => IR rd::nil + | PArithRRR i rd rs1 rs2 => IR rd::nil + | PArithRRI32 i rd rs imm => IR rd::nil + | PArithRRI64 i rd rs imm => IR rd::nil + (* Alloc and freeframe *) + | Pallocframe _ _ | Pfreeframe _ _ | Pbuiltin _ _ _ => all_bregs + (* Instructions that do not write *) + | Pnop | Pret | Pgoto _ | Pj_l _ | Pcb _ _ _ | Pcbu _ _ _ | PStoreRRO _ _ _ _ => nil + end. + +(* Definition disjoint {A: Type} (l l':list A) : Prop := forall r, In r l -> In r l' -> False. *) + +(* Inductive definition of disjoint, easier to reason with *) +Inductive disjoint {A: Type} : list A -> list A -> Prop := + | disjoint_nilr : forall l, disjoint l nil + | disjoint_nill : forall l, disjoint nil l + | disjoint_consl : forall l l' e, disjoint l l' -> (~ In e l') -> disjoint (e::l) l' + | disjoint_consr : forall l l' e, disjoint l l' -> (~ In e l) -> disjoint l (e::l') + . + +Example disjoint_ex1: disjoint (4::2::1::nil) (3::5::7::nil). +Proof. + repeat constructor. + all: try (intro H; simpl in H; + repeat (match goal with h:_ \/ _ |- _ => inversion_clear h; [discriminate|] | _ => fail end); contradiction). +Qed. + +Inductive depfree : list breg -> list breg -> list instruction -> Prop := + | depfree_nil : forall lw lr, depfree lw lr nil + | depfree_cons : forall i lri lwi lw lr l, + lri = readregs i -> lwi = writeregs i -> + disjoint lwi lw -> (* Checking for WAW *) + disjoint lwi lr -> (* Checking for RAW *) + depfree (lr++lri) (lw++lwi) l -> + depfree lr lw (i::l) + . + (* FIXME: STUB *) Definition is_bundle (b:bblock):=True. -- cgit From ffaf5a655456e045f116fcd6b52e4faae9c8a7d4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 24 Sep 2018 23:16:07 +0200 Subject: relecture --- mppa_k1c/Asmblock.v | 4 +- mppa_k1c/Asmbundle.v | 171 +++++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 148 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ba14c451..4f825bf5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -576,7 +576,6 @@ Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := Section RELSEM. -Variable ge: genv. (** The semantics is purely small-step and defined as a function from the current state (a register set + a memory state) @@ -713,6 +712,9 @@ FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.v *) +Variable ge: genv. + + Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregset := match ai with | PArithR n d => diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v index 14a2ea7e..b5f92c2a 100644 --- a/mppa_k1c/Asmbundle.v +++ b/mppa_k1c/Asmbundle.v @@ -14,6 +14,19 @@ Require Import Conventions. Require Export Asmblock. Require Import ListSet. + +Fixpoint notIn {A} (x: A) (l:list A): Prop := + match l with + | nil => True + | a::l' => x <> a /\ notIn x l' + end. + +Lemma notIn_rewrite A (r:A) l: (~List.In r l) <-> notIn r l. +Proof. + induction l; simpl; intuition. +Qed. + + Section RELSEM. Variable ge: genv. @@ -44,6 +57,71 @@ Proof. - unfold all_bregs. repeat (apply in_app_iff; right). simpl. left; auto. Qed. +Definition writeregs (i: instruction): list breg := + match i with + (* Control instructions *) + | Pset rd rs => rd::nil + | Pget rd rs => IR rd::nil + | Pcall s => RA::nil + (* Load *) + | PLoadRRO i rd ra o => IR rd::nil + (* Arith *) + | PArithR i rd => IR rd::nil + | PArithRR i rd rs => IR rd::nil + | PArithRI32 i rd imm => IR rd::nil + | PArithRI64 i rd imm => IR rd::nil + | PArithRRR i rd rs1 rs2 => IR rd::nil + | PArithRRI32 i rd rs imm => IR rd::nil + | PArithRRI64 i rd rs imm => IR rd::nil + (* Alloc and freeframe *) + | Pallocframe _ _ => IR FP::IR GPR31::IR SP :: nil + | Pfreeframe _ _ => IR GPR31::IR SP :: nil + (* builtins : only implemented in OCaml, we know nothing about them *) + | Pbuiltin _ _ _ => all_bregs + (* Instructions that do not write *) + | Pnop | Pret | Pgoto _ | Pj_l _ | Pcb _ _ _ | Pcbu _ _ _ | PStoreRRO _ _ _ _ => nil + end. + +Lemma update_PC_breg (rs: regset) v (r: breg): + (rs#PC <-- v) r = rs r. +Proof. + rewrite Pregmap.gso; congruence. +Qed. + +Lemma update_pregs_diff (rs:regset) rd x r: r <> rd -> update_pregs rs (rs # rd <- x) r = rs r. +Proof. + unfold update_pregs. intro H. rewrite Bregmap.gso; congruence. +Qed. + +Hint Rewrite update_PC_breg update_pregs_diff: regset_rw. + +Fact writeregs_correct f i rs m rs' m' r: + ~(List.In r (writeregs i)) -> + (exec_bblock ge f (bblock_single_inst i) rs m) = Next rs' m' -> + rs' r = rs r. +Proof. + rewrite notIn_rewrite. + unfold exec_bblock, nextblock, size; destruct i; simpl. + destruct i; simpl. + destruct i; simpl; try ( + destruct i; simpl; intro H; decompose [and] H; clear H; + intros H; inversion_clear H; + autorewrite with regset_rw; auto; fail). + - (* LOAD *) destruct i; simpl. + destruct i; simpl; unfold exec_load; + destruct (Mem.loadv _ _ _); try discriminate; + intro H; decompose [and] H; clear H; + intros H; inversion_clear H; + autorewrite with regset_rw; auto. + - (* STORE *) destruct i; simpl. + destruct i; simpl; unfold exec_store; + destruct (Mem.storev _ _ _ _); try discriminate; + intro H; clear H; + intros H; inversion_clear H; + autorewrite with regset_rw; auto. + - (* ALLOCFRAME *) +Admitted. + Definition readregs (i: instruction) : list breg := match i with (* Control instructions *) @@ -60,37 +138,67 @@ Definition readregs (i: instruction) : list breg := | PArithRRR i rd rs1 rs2 => IR rs1 :: IR rs2 :: nil | PArithRRI32 i rd rs imm => IR rs :: nil | PArithRRI64 i rd rs imm => IR rs :: nil - (* Alloc and freeframe and builtins : implemented in OCaml, we know nothing about them *) - | Pallocframe _ _ | Pfreeframe _ _ | Pbuiltin _ _ _ => all_bregs + (* Alloc and freeframe (from the semantics) *) + | Pallocframe _ _ | Pfreeframe _ _ => IR SP :: nil + (* builtins : only implemented in OCaml, we know nothing about them *) + | Pbuiltin _ _ _ => all_bregs (* Instructions that do not read *) | Pnop | Pcall _ | Pgoto _ | Pj_l _ | PArithR _ _ | PArithRI32 _ _ _ | PArithRI64 _ _ _ => nil end. -Definition writeregs (i: instruction): list breg := - match i with - (* Control instructions *) - | Pset rd rs => rd::nil - | Pget rd rs => IR rd::nil - | Pcall s => RA::nil - (* Load *) - | PLoadRRO i rd ra o => IR rd::nil - (* Arith *) - | PArithR i rd => IR rd::nil - | PArithRR i rd rs => IR rd::nil - | PArithRI32 i rd imm => IR rd::nil - | PArithRI64 i rd imm => IR rd::nil - | PArithRRR i rd rs1 rs2 => IR rd::nil - | PArithRRI32 i rd rs imm => IR rd::nil - | PArithRRI64 i rd rs imm => IR rd::nil - (* Alloc and freeframe *) - | Pallocframe _ _ | Pfreeframe _ _ | Pbuiltin _ _ _ => all_bregs - (* Instructions that do not write *) - | Pnop | Pret | Pgoto _ | Pj_l _ | Pcb _ _ _ | Pcbu _ _ _ | PStoreRRO _ _ _ _ => nil +Axiom TODO: False. + +Definition outcome_equiv (r: breg) v (o1 o2: outcome (rgset:=regset)) := + match o1 with + | Next rs1 m1 => exists rs2, exists m2, o2=Next rs2 m2 /\ (forall r, (rs1#r <-- v) r = rs2 r) /\ (forall chunk p, Mem.loadv chunk m1 p = Mem.loadv chunk m2 p) + | Stuck => o2 = Stuck end. -(* Definition disjoint {A: Type} (l l':list A) : Prop := forall r, In r l -> In r l' -> False. *) +Fact useregs_correct f i rs m r v: + ~(List.In r ((readregs i)++(writeregs i))) -> + outcome_equiv r v + (exec_bblock ge f (bblock_single_inst i) rs m) + (exec_bblock ge f (bblock_single_inst i) (rs#r <-- v) m). +Proof. + rewrite notIn_rewrite. + unfold exec_bblock, nextblock, size; destruct i; simpl. + + destruct i; simpl. + - destruct i; simpl. + * intro H; decompose [and] H; clear H. (* H useless *) + elim TODO. + * intro H; decompose [and] H; clear H. + destruct i; simpl. + simpl; eexists; eexists; constructor 1; eauto. + intuition. + destruct r0. + rewrite! update_PC_breg. + (* TODO: lemma on rs # _ <-- _ *) +Abort. + +(* alternative definition of disjoint *) +Definition disjoint_x {A: Type} (l l':list A) : Prop := forall r, In r l -> ~In r l'. (* TODO: use notIn instead ? *) + +Example disjoint_x_ex1: disjoint_x (4::2::1::nil) (3::5::7::nil). +Proof. + unfold disjoint_x; simpl. intuition. +Qed. + +Lemma disjoint_x_nilr : forall A (l:list A), disjoint_x l nil. +Proof. + unfold disjoint_x; simpl. intuition. +Qed. + +Lemma disjoint_x_consl : forall A l l' (e:A), disjoint_x l l' -> (~ In e l') -> disjoint_x (e::l) l'. +Proof. + unfold disjoint_x; simpl. intuition (subst; eauto). +Qed. + +(* Inductive definition of disjoint, easier to reason with + +Sylvain: I am not sure. Actually, from the above definition, we can still prove the following "constructors" as lemma if needed + (cf. example above). +*) -(* Inductive definition of disjoint, easier to reason with *) Inductive disjoint {A: Type} : list A -> list A -> Prop := | disjoint_nilr : forall l, disjoint l nil | disjoint_nill : forall l, disjoint nil l @@ -106,15 +214,26 @@ Proof. Qed. Inductive depfree : list breg -> list breg -> list instruction -> Prop := - | depfree_nil : forall lw lr, depfree lw lr nil + | depfree_nil : forall lr lw, depfree lr lw nil | depfree_cons : forall i lri lwi lw lr l, lri = readregs i -> lwi = writeregs i -> disjoint lwi lw -> (* Checking for WAW *) - disjoint lwi lr -> (* Checking for RAW *) + disjoint lri lw -> (* Checking for RAW *) depfree (lr++lri) (lw++lwi) l -> depfree lr lw (i::l) . +(* une version alternative *) +Inductive depfreex : list breg -> list instruction -> Prop := + | depfreex_nil : forall lw, depfreex lw nil + | depfreex_cons : forall i lri lwi lw l, + lri = readregs i -> lwi = writeregs i -> + disjoint (lri++lwi) lw -> (* Checking for WAW + RAW *) + depfreex (lw++lwi) l -> + depfreex lw (i::l) + . + + (* FIXME: STUB *) Definition is_bundle (b:bblock):=True. -- cgit From 5b1c4771836a246e75eec07ccb1b72c83841baab Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 25 Sep 2018 10:14:54 +0200 Subject: add an example on depfree --- mppa_k1c/Asmbundle.v | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v index b5f92c2a..bd531930 100644 --- a/mppa_k1c/Asmbundle.v +++ b/mppa_k1c/Asmbundle.v @@ -228,11 +228,29 @@ Inductive depfreex : list breg -> list instruction -> Prop := | depfreex_nil : forall lw, depfreex lw nil | depfreex_cons : forall i lri lwi lw l, lri = readregs i -> lwi = writeregs i -> - disjoint (lri++lwi) lw -> (* Checking for WAW + RAW *) + disjoint_x lri lw -> (* Checking for RAW *) + disjoint_x lwi lw -> (* Checking for WAW *) depfreex (lw++lwi) l -> depfreex lw (i::l) . +Import ListNotations. + +Open Scope list_scope. + +Local Hint Resolve depfreex_nil depfreex_cons. + +Example depfreex_2 i1 i2 lw1 lr2 lw2: + lw1 = writeregs i1 -> + lr2 = readregs i2 -> + lw2 = writeregs i2 -> + disjoint_x lr2 lw1 -> (* RAW *) + disjoint_x lw2 lw1 -> (* WAW *) + depfreex [] [i1;i2]. +Proof. + intros; eapply depfreex_cons; eauto; + unfold disjoint_x; simpl; intuition. +Qed. (* FIXME: STUB *) Definition is_bundle (b:bblock):=True. -- cgit From 589626969d7521b02db946e74736a0e2afe0dcb0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 25 Sep 2018 15:37:45 +0200 Subject: MB2AB - Proof of external function step --- mppa_k1c/Asmblock.v | 14 +++++------ mppa_k1c/Asmblockgenproof.v | 25 ++++++++++++++++--- mppa_k1c/Asmblockgenproof0.v | 59 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 85 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 4f825bf5..4a4ffc10 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -548,10 +548,10 @@ Fixpoint undef_regs (l: list preg) (rs: regset) : regset := (** Assigning a register pair *) -Definition set_pair (p: rpair breg) (v: val) (rs: bregset) : bregset := +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := match p with - | One r => rs#r <- v - | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + | One r => rs#r <-- v + | Twolong rhi rlo => rs#rhi <-- (Val.hiword v) #rlo <-- (Val.loword v) end. (* TODO: Is it still useful ?? *) @@ -1093,8 +1093,8 @@ Definition extcall_arguments (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. -Definition loc_external_result (sg: signature) : rpair breg := - map_rpair breg_of (loc_result sg). +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). (** Execution of the instruction at [rs PC]. *) @@ -1134,7 +1134,7 @@ Inductive stepin: option bblock -> state -> trace -> state -> Prop := Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (update_pregs rs (set_pair (loc_external_result (ef_sig ef) ) res rs))#PC <-- (rs RA) -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <-- (rs RA) -> stepin None (State rs m) t (State rs' m') . @@ -1172,7 +1172,7 @@ Lemma exec_step_external b ef args res rs m t rs' m': Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (update_pregs rs (set_pair (loc_external_result (ef_sig ef) ) res rs))#PC <-- (rs RA) -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <-- (rs RA) -> step (State rs m) t (State rs' m') . Proof. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c2a609c9..f0842c4d 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -47,7 +47,7 @@ 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 -> @@ -55,6 +55,7 @@ Lemma functions_translated: 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) -> @@ -1079,11 +1080,27 @@ Theorem step_simulation: (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. - - destruct TODO. + induction 1; intros; inv MS. - destruct TODO. - destruct TODO. - - inv MS. inv STACKS. simpl in *. + +- (* external function *) + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + + - (* return *) + inv STACKS. simpl in *. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 52ba9ca2..15cd88b5 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -169,7 +169,7 @@ Proof. Qed. *) -(* Lemma agree_set_pair: +Lemma agree_set_pair: forall sp p v v' ms rs, agree ms sp rs -> Val.lessdef v v' -> @@ -180,7 +180,6 @@ Proof. - apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. Qed. - *) Lemma agree_undef_nondata_regs: forall ms sp rl rs, @@ -255,6 +254,62 @@ Proof. intros. rewrite Pregmap.gso; auto with asmgen. Qed. +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. (* inspired from Mach *) -- cgit From fa5167f016145b5732b4da3c2aea26d808c63556 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 25 Sep 2018 18:17:43 +0200 Subject: MB2AB - un peu d'avancement sur internal function --- mppa_k1c/Asmblock.v | 14 ++--- mppa_k1c/Asmblockgenproof.v | 80 ++++++++++++++++++++++++-- mppa_k1c/Asmblockgenproof0.v | 134 ++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 214 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 4a4ffc10..2720f3e5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -99,13 +99,6 @@ End PregEq. Module Pregmap := EMap(PregEq). -Definition pregs_to_bregs {A} (rs: Pregmap.t A): (Bregmap.t A) - := fun r => rs (BaR r). - -Definition update_pregs {A} (rs1: Pregmap.t A) (rs2:Bregmap.t A): Pregmap.t A - := fun r => match r with BaR r => rs2 r | _ => rs1 r end. - - (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) Notation "'SP'" := GPR12 (only parsing) : asm. @@ -537,6 +530,11 @@ Notation "a # b <-- c" := (Pregmap.set b c a) (at level 1, b at next level) : as Open Scope asm. +Definition pregs_to_bregs {A} (rs: Pregmap.t A): (Bregmap.t A) + := fun r => rs (BaR r). + +Definition update_pregs {A} (rs1: Pregmap.t A) (rs2:Bregmap.t A): Pregmap.t A + := fun r => match r with BaR r => rs2 r | _ => rs1 r end. (** Undefining some registers *) @@ -1033,7 +1031,7 @@ end. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := match exec_body (body b) rs0 m with - | Next rs' m' => + | Next rs' m' => let rs1 := nextblock b (update_pregs rs0 rs') in match (exit b) with | None => Next rs1 m' diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index f0842c4d..a9604c14 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1081,10 +1081,82 @@ Theorem step_simulation: \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. Proof. induction 1; intros; inv MS. - - destruct TODO. - - destruct TODO. -- (* external function *) +- destruct TODO. + +- (* internal function *) + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b + Pget GPR8 RA ::b + storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) + (rs0#FP <-- (parent_sp s) #SP <-- sp #GPR31 <-- Vundef)). + destruct TODO. +(* exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } + rewrite H3. rewrite H4. + (* change (rs' GPR8) with (rs0 RA). *) + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. + congruence. congruence. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: + exec_straight tge tf + tf.(fn_code) rs0 m' + x0 rs3 m3'). + { change (fn_code tf) with tfbody; unfold tfbody. + apply exec_straight_step with rs2 m2'. + unfold exec_instr. rewrite C. fold sp. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. + reflexivity. + eapply exec_straight_trans. + - eexact U'. + - eexact U. } + exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3 m3'); split. + eapply exec_straight_steps_1; eauto. omega. constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite V. + assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H6; 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 V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. + *) - (* external function *) exploit functions_translated; eauto. intros [tf [A B]]. simpl in B. inv B. exploit extcall_arguments_match; eauto. @@ -1099,7 +1171,7 @@ Proof. apply agree_set_other; auto. apply agree_set_pair; auto. - - (* return *) +- (* return *) inv STACKS. simpl in *. right. split. omega. split. auto. rewrite <- ATPC in H5. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 15cd88b5..f6e89a36 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -70,6 +70,24 @@ 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. + (** * Agreement between Mach registers and processor registers *) Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { @@ -401,7 +419,6 @@ Qed. Local Hint Resolve code_tail_next. -(* is it useful ? Lemma code_tail_next_int: forall fn ofs bi c, size_blocks fn <= Ptrofs.max_unsigned -> @@ -417,7 +434,6 @@ Proof. omega. - rewrite Ptrofs.unsigned_repr; omega. Qed. -*) (** Predictor for return addresses in generated Asm code. @@ -532,6 +548,120 @@ Inductive transl_code_at_pc (ge: MB.genv): code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr (rs1 PC) (Ptrofs.repr (size b1)) -> + exec_straight (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr (rs1 PC) (Ptrofs.repr (size b)) -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall b1 b2 c rs1 m1 rs2 m2 rs3 m3, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + exec_bblock ge fn b2 rs2 m2 = Next rs3 m3 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + rs3#PC = Val.offset_ptr rs2#PC (Ptrofs.repr (size b2)) -> + exec_straight (b1 :: b2 :: c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall b1 b2 b3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + exec_bblock ge fn b2 rs2 m2 = Next rs3 m3 -> + exec_bblock ge fn b3 rs3 m3 = Next rs4 m4 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + rs3#PC = Val.offset_ptr rs2#PC (Ptrofs.repr (size b2)) -> + rs4#PC = Val.offset_ptr rs3#PC (Ptrofs.repr (size b3)) -> + exec_straight (b1 :: b2 :: b3 :: c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + repeat (econstructor; eauto). + eapply find_bblock_tail. eauto. + eapply plus_left'. + repeat (econstructor; eauto). + eapply find_bblock_tail. eauto. + apply IHexec_straight with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + + (** * Properties of the Machblock call stack *) Section MATCH_STACK. -- cgit From 43f1ff52d806099f3bf16726ac2d8a782f4bba98 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 26 Sep 2018 11:56:32 +0200 Subject: MB2AB - Adding Asmblockgenproof1.v --- mppa_k1c/Asmblockgenproof1.v | 1595 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1595 insertions(+) create mode 100644 mppa_k1c/Asmblockgenproof1.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v new file mode 100644 index 00000000..8b686676 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof1.v @@ -0,0 +1,1595 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Errors Maps. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Machblock Conventions. +Require Import Asmblock Asmblockgen Asmblockgenproof0. + +(* (** Decomposition of integer constants. *) + +Lemma make_immed32_sound: + forall n, + match make_immed32 n with + | Imm32_single imm => n = imm + end. +Proof. + intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). + predSpec Int.eq Int.eq_spec n lo; auto. +(* +- auto. +- set (m := Int.sub n lo). + assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). + assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). + { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + auto using Int.eqmod_sub, Int.eqmod_refl. } + assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). + { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. + apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists (two_p (32-12)); auto. } + assert (D: Int.modu m (Int.repr 4096) = Int.zero). + { apply Int.eqmod_mod_eq in C. unfold Int.modu. + change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. + reflexivity. + apply two_p_gt_ZERO; omega. } + rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. + rewrite Int.shl_mul_two_p. + change (two_p (Int.unsigned (Int.repr 12))) with 4096. + replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. + unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). + rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. + rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). + rewrite D. apply Int.add_zero. +*) +Qed. + +Lemma make_immed64_sound: + forall n, + match make_immed64 n with + | Imm64_single imm => n = imm +(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo + | Imm64_large imm => n = imm +*)end. +Proof. + intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). + predSpec Int64.eq Int64.eq_spec n lo. +- auto. +- set (m := Int64.sub n lo). + set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). + predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). + auto. + auto. +Qed. + +(** Properties of registers *) + +Lemma ireg_of_not_GPR31: + forall m r, ireg_of m = OK r -> IR r <> IR GPR31. +Proof. + intros. erewrite <- ireg_of_eq; eauto with asmgen. +Qed. + +Lemma ireg_of_not_GPR31': + forall m r, ireg_of m = OK r -> r <> GPR31. +Proof. + intros. apply ireg_of_not_GPR31 in H. congruence. +Qed. + +Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. + +*) +(** Useful simplification tactic *) + +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. + +(** * Correctness of RISC-V constructor functions *) + +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', + exec_straight ge fn (loadimm32 rd n k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + +Lemma loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + 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 <> GPR31 -> + 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 <> GPR31 -> 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 GPR31 hi lo (op rd r1 GPR31 :: 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) + (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 (Vlong n)))) m) -> + forall rd r1 n k rs, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs##r1 (Vlong n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm64. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +(* +- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: 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 *) + +Lemma addptrofs_correct: + forall rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold addptrofs; intros. + destruct (Ptrofs.eq_dec n Ptrofs.zero). +- subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. + intros; Simpl. +- unfold addimm64. + exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. unfold getw. destruct (rs r1); simpl; auto. + 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 <> GPR31 -> 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 <> GPR31 -> 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_GPR31: + forall normal lbl (rs: regset) m b, + rs#GPR31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 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 + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge fn c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma transl_comp_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs##r1 rs##r2) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2) as cmpubool. + destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compl_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_complu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_opt_compuimm_correct: + forall n cmp r1 lbl k rs m b c, + select_comp n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 (Vint n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compuimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcbu BTweqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) + auto; + unfold eval_branch. unfold getw. rewrite H0 in H2. unfold getw in H2. + rewrite H1. rewrite H2; auto. + - (* c = Cne *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcbu BTwnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite <- H0. rewrite H1. rewrite H2. auto. + - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_opt_compluimm_correct: + forall n cmp r1 lbl k rs m b c, + select_compl n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 (Vlong n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compluimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcbu BTdeqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Cne *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcbu BTdnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_cbranch_correct_1: + forall cond args lbl k c m ms b sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some b -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros TRANSL EVAL AG MEXT. + set (vl' := map rs (map preg_of args)). + assert (EVAL': eval_condition cond vl' m' = Some b). + { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } + clear EVAL MEXT AG. + destruct cond; simpl in TRANSL; ArgsInv. +(* Ccomp *) +- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompu *) +- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompimm *) +- remember (Int.eq n Int.zero) as eqz. + destruct eqz. + + assert (n = (Int.repr 0)). { + destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. + generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpswz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getw; rewrite EVAL'; auto. + + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompuimm *) +- remember (select_comp n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compuimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompl *) +- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplu *) +- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplimm *) +- remember (Int64.eq n Int64.zero) as eqz. + destruct eqz. + + assert (n = (Int64.repr 0)). { + destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. + generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getl; rewrite EVAL'; auto. + + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } + +(* Ccompluimm *) +- remember (select_compl n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compluimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +Qed. + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some true -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. + +Lemma transl_cbranch_correct_false: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some false -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', + exec_straight ge fn c rs m' k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. exploit transl_cbranch_correct_1; eauto. simpl. + intros (rs' & insn & A & B & C). + exists (nextinstr rs'). + split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. + intros; Simpl. +Qed. + +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; auto. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; 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 fn (cast32signed d s 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. Simpl. + + split. + * rewrite e. Simpl. + * intros. destruct r; Simpl. +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. Simpl. + + split. + * Simpl. + * intros. destruct r; Simpl. +Qed. + +(* Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto | reflexivity] + | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } +Opaque Int.eq. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* Omove *) + destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrsymbol *) + destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. ++ TranslOpSimpl. +- (* Oaddrstack *) + exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* Ocast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. unfold getw. + 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. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. unfold getw. + 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 *) + clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; unfold getw; Simpl. +- (* Ocast32signed *) + exploit cast32signed_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. split. apply B. + intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } + apply C; auto. +- (* longofintu *) + econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. + split; intros; Simpl. unfold getl; unfold Pregmap.set; Simpl. destruct (PregEq.eq x0 x0). + + destruct (rs x0); auto. simpl. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. + rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. + + contradict n. auto. +- (* Ocmp *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. +(* +- (* intconst *) + exploit loadimm32_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* longconst *) + exploit loadimm64_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* floatconst *) + destruct (Float.eq_dec n Float.zero). ++ subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. +- (* singleconst *) + destruct (Float32.eq_dec n Float32.zero). ++ subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. +- (* stackoffset *) + exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* addimm *) + exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* andimm *) + exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* orimm *) + exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* xorimm *) + exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. + + + +- (* addlimm *) + exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. + +- (* andimm *) + exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* orimm *) + exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* xorimm *) + exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. +- (* shrxlimm *) + clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. +*) +Qed. + + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: + forall mk_instr base ofs k rs m, + base <> GPR31 -> + exists base' ofs' rs', + exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m + (mk_instr base' ofs' :: k) rs' m + /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64 eqn:SF. *) + assert (Archi.ptr64 = true) as SF; auto. +- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. + destruct (make_immed64 (Ptrofs.to_int64 ofs)). ++ 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 -> instruction) rd m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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 -> + base <> GPR31 -> rd <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_load. rewrite B, LOAD. eauto. Simpl. + split; intros; Simpl. +Qed. + +Lemma indexed_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) r1 m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + forall (base: ireg) ofs k (rs: regset) m', + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> + base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. + intros; Simpl. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR LOAD NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). + { unfold loadind in TR. + destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_load_access_correct; eauto with asmgen. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + base <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR STORE NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. +Qed. + +*) + +Definition noscroll := 0. + +Ltac bsimpl := unfold exec_bblock; simpl. + +Lemma Pget_correct: + forall (dst: gpreg) (src: breg) k (rs: regset) m, + src = RA -> + exists rs', + exec_straight ge fn (Pget dst src ::b k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor. +- rewrite H. bsimpl. auto. +- Simpl. +(* - Simpl. +- intros. rewrite H. Simpl. + *)Admitted. + +(* + +Lemma Pset_correct: + forall (dst: preg) (src: gpreg) k (rs: regset) m, + dst = RA -> + exists rs', + exec_straight ge fn (Pset dst src ::i k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor; simpl. + rewrite H. auto. + Simpl. + Simpl. + intros. rewrite H. Simpl. +Qed. + +Lemma loadind_ptr_correct: + forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> GPR31 -> 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 H1. auto. +Qed. + +Lemma storeind_ptr_correct: + forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', + Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + base <> GPR31 -> src <> GPR31 -> + exists rs', + exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true); auto. +Qed. + +Lemma transl_memory_access_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ofs rs', + exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m + /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access in TR; destruct addr; ArgsInv. +- (* indexed *) + inv EV. apply indexed_memory_access_correct; eauto with asmgen. +- (* global *) + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. + constructor. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. unfold eval_offset. + assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). + { apply Val.offset_ptr_zero. } + remember (Genv.symbol_address ge i i0) as symbol. + destruct symbol; auto. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + simpl. rewrite Ptrofs.add_zero; auto. +- (* stack *) + inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. +Qed. + +Lemma transl_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c rd (rs: regset) m v v', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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' -> + rd <> PC -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros INSTR TR EV LOAD NOTPC. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> + r1 <> PC -> r1 <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOTPC NOT31. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. + intros; Simpl. +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 -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV LOAD. + assert (A: exists mk_instr, + transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). + { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } + destruct A as (mk_instr & B & C). + eapply transl_load_access_correct; eauto with asmgen. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m a m', + transl_store chunk addr args src k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR EV STORE. + assert (A: exists mk_instr chunk', + transl_memory_access mk_instr addr args k = OK c + /\ (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). + { unfold transl_store in TR; destruct chunk; ArgsInv; + (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). + destruct a; auto. apply Mem.store_signed_unsigned_8. + destruct a; auto. apply Mem.store_signed_unsigned_16. + } + destruct A as (mk_instr & chunk' & B & C & D). + rewrite D in STORE; clear D. + eapply transl_store_access_correct; eauto with asmgen. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). +Proof. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. + + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 + ::i Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs tm). + - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. + - congruence. + - intros (rs1 & A1 & B1 & C1). + assert (agree ms (Vptr stk soff) rs1) as AG1. + + destruct AG. + apply mkagree; auto. + rewrite C1; discriminate || auto. + intro. rewrite C1; auto; destruct r; simpl; try discriminate. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs1 tm). auto. + intros (rs2 & A2 & B2 & C2). + econstructor; econstructor; split. + * eapply exec_straight_trans. + { eexact A1. } + { eapply exec_straight_trans. + { eapply A2. } + { apply exec_straight_one. simpl. + rewrite (C2 GPR12) 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. + 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. + split. auto. + split. Simpl. rewrite B2. auto. + split. Simpl. + intros. Simpl. + rewrite C2; auto. +Qed. + +*) +End CONSTRUCTORS. + + -- cgit From 9247603461ccf05167d753e4e023ef5cc692d08d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 26 Sep 2018 11:52:53 +0200 Subject: AB: removing bregs --- mppa_k1c/Asmblock.v | 105 +++++++++++++++---------------------------- mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof0.v | 14 +++--- mppa_k1c/Asmblockgenproof1.v | 6 +-- mppa_k1c/Asmbundle.v | 43 ++++++++++-------- 5 files changed, 73 insertions(+), 97 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 2720f3e5..f066a1a2 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -63,34 +63,18 @@ Proof. decide equality. Defined. (** We model the following registers of the RISC-V architecture. *) (** basic register *) -Inductive breg: Type := - | IR: gpreg -> breg (**r integer registers *) - | FR: gpreg -> breg (**r float registers *) - | RA: breg - . - -Coercion IR: gpreg >-> breg. -Coercion FR: gpreg >-> breg. - -Lemma breg_eq: forall (x y: breg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. - - -Module BregEq. - Definition t := breg. - Definition eq := breg_eq. -End BregEq. - -Module Bregmap := EMap(BregEq). - Inductive preg: Type := - | BaR: breg -> preg (**r basic registers *) - | PC: preg. (**r program counter *) + | IR: gpreg -> preg (**r integer registers *) + | FR: gpreg -> preg (**r float registers *) + | RA: preg + | PC: preg + . -Coercion BaR: breg >-> preg. +Coercion IR: gpreg >-> preg. +Coercion FR: gpreg >-> preg. Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply breg_eq. Defined. +Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. Module PregEq. Definition t := preg. @@ -378,8 +362,8 @@ Inductive basic : Type := | PStore (i: st_instruction) | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Pget (rd: ireg) (rs: breg) (**r get system register *) - | Pset (rd: breg) (rs: ireg) (**r set system register *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) | Pnop (**r virtual instruction that does nothing *) . @@ -514,42 +498,29 @@ Qed. type [Tint] or [Tlong] (in 64 bit mode), and float registers to values of type [Tsingle] or [Tfloat]. *) -Definition bregset := Bregmap.t val. Definition regset := Pregmap.t val. -Definition bregset_cast (rs: regset): bregset - := fun r => rs (BaR r). - -Coercion bregset_cast: regset >-> bregset. - Definition genv := Genv.t fundef unit. Notation "a # b" := (a b) (at level 1, only parsing) : asm. -Notation "a # b <- c" := (Bregmap.set b c a) (at level 1, b at next level) : asm. -Notation "a # b <-- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. Open Scope asm. -Definition pregs_to_bregs {A} (rs: Pregmap.t A): (Bregmap.t A) - := fun r => rs (BaR r). - -Definition update_pregs {A} (rs1: Pregmap.t A) (rs2:Bregmap.t A): Pregmap.t A - := fun r => match r with BaR r => rs2 r | _ => rs1 r end. - (** Undefining some registers *) Fixpoint undef_regs (l: list preg) (rs: regset) : regset := match l with | nil => rs - | r :: l' => undef_regs l' (rs#r <-- Vundef) + | r :: l' => undef_regs l' (rs#r <- Vundef) end. (** Assigning a register pair *) Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := match p with - | One r => rs#r <-- v - | Twolong rhi rlo => rs#rhi <-- (Val.hiword v) #rlo <-- (Val.loword v) + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) end. (* TODO: Is it still useful ?? *) @@ -567,7 +538,7 @@ Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := match res with - | BR r => rs#r <-- v + | BR r => rs#r <- v | BR_none => rs | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) end. @@ -713,7 +684,7 @@ FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.v Variable ge: genv. -Definition exec_arith_instr (ai: ar_instruction) (rs: bregset) (m: mem) : bregset := +Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset := match ai with | PArithR n d => match n with @@ -817,15 +788,15 @@ Definition eval_offset (ofs: offset) : ptrofs := | Ofslow id delta => low_half ge id delta end. -Definition exec_load (chunk: memory_chunk) (rs: bregset) (m: mem) - (d: breg) (a: ireg) (ofs: offset) := +Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) + (d: ireg) (a: ireg) (ofs: offset) := match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with | None => Stuck | Some v => Next (rs#d <- v) m end. -Definition exec_store (chunk: memory_chunk) (rs: bregset) (m: mem) - (s: breg) (a: ireg) (ofs: offset) := +Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) + (s: ireg) (a: ireg) (ofs: offset) := match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with | None => Stuck | Some m' => Next rs m' @@ -833,7 +804,7 @@ Definition exec_store (chunk: memory_chunk) (rs: bregset) (m: mem) (** * basic instructions *) -Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset := +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset := match bi with | PArith ai => Next (exec_arith_instr ai rs m) m @@ -897,7 +868,7 @@ Definition exec_basic_instr (bi: basic) (rs: bregset) (m: mem) : outcome bregset | Pnop => Next rs m end. -Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := +Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome regset := match body with | nil => Next rs m | bi::body' => @@ -911,7 +882,7 @@ Fixpoint exec_body (body: list basic) (rs: bregset) (m: mem): outcome bregset := instruction ([nextblock]) or branching to a label ([goto_label]). *) Definition nextblock (b:bblock) (rs: regset) := - rs#PC <-- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). + rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). (** Looking up bblocks in a code sequence by position. *) Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := @@ -962,7 +933,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <-- (Vptr b (Ptrofs.repr pos))) m + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -1003,11 +974,11 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc (** Branch Control Unit instructions *) | Pret => - Next (rs#PC <-- (rs#RA)) m + Next (rs#PC <- (rs#RA)) m | Pcall s => - Next (rs#RA <-- (rs#PC) #PC <-- (Genv.symbol_address ge s Ptrofs.zero)) m + Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pgoto s => - Next (rs#PC <-- (Genv.symbol_address ge s Ptrofs.zero)) m + Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pj_l l => goto_label f l rs m | Pcb bt r l => @@ -1032,7 +1003,7 @@ end. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := match exec_body (body b) rs0 m with | Next rs' m' => - let rs1 := nextblock b (update_pregs rs0 rs') in + let rs1 := nextblock b rs' in match (exit b) with | None => Next rs1 m' | Some ic => exec_control f ic rs1 m' @@ -1046,7 +1017,7 @@ Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcom code. *) (* FIXME - R31 is not there *) -Definition breg_of (r: mreg) : breg := +Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 @@ -1063,15 +1034,13 @@ Definition breg_of (r: mreg) : breg := | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 end. -Definition preg_of (r: mreg) : preg := breg_of r. - (** Extract the values of the arguments of an external call. We exploit the calling conventions from module [Conventions], except that we use RISC-V registers instead of locations. *) Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (breg_of r)) + extcall_arg rs m (R r) (rs (preg_of r)) | extcall_arg_stack: forall ofs ty bofs v, bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> Mem.loadv (chunk_of_type ty) m @@ -1124,7 +1093,7 @@ Inductive stepin: option bblock -> state -> trace -> state -> Prop := rs' = nextblock bi (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <-- Vundef))) -> + (rs#GPR31 <- Vundef))) -> stepin (Some bi) (State rs m) t (State rs' m') | exec_stepin_external: forall b ef args res rs m t rs' m', @@ -1132,7 +1101,7 @@ Inductive stepin: option bblock -> state -> trace -> state -> Prop := Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <-- (rs RA) -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> stepin None (State rs m) t (State rs' m') . @@ -1159,7 +1128,7 @@ Lemma exec_step_builtin b ofs f ef args res rs m vargs t vres rs' m' bi: rs' = nextblock bi (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <-- Vundef))) -> + (rs#GPR31 <- Vundef))) -> step (State rs m) t (State rs' m'). Proof. intros; eexists. eapply exec_stepin_builtin; eauto. @@ -1170,7 +1139,7 @@ Lemma exec_step_external b ef args res rs m t rs' m': Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <-- (rs RA) -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> step (State rs m) t (State rs' m') . Proof. @@ -1187,9 +1156,9 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <-- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # SP <-- Vnullptr - # RA <-- Vnullptr in + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <- Vnullptr + # RA <- Vnullptr in Genv.init_mem p = Some m0 -> initial_state p (State rs0 m0). diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index a9604c14..345f71b2 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1103,7 +1103,7 @@ Proof. storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) - (rs0#FP <-- (parent_sp s) #SP <-- sp #GPR31 <-- Vundef)). + (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). destruct TODO. (* exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. intros (rs' & U' & V'). diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index f6e89a36..309dbc2c 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -17,22 +17,24 @@ Require Import Asmblockgen. Module MB:=Machblock. Module AB:=Asmblock. +Hint Extern 2 (_ <> _) => congruence: asmgen. + 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. +(* 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. +(* destruct b. all: try discriminate. inv H1. auto. -Qed. + *)Qed. Lemma preg_of_injective: @@ -173,7 +175,7 @@ Lemma agree_set_other: forall ms sp rs r v, agree ms sp rs -> data_preg r = false -> - agree ms sp (rs#r <-- v). + agree ms sp (rs#r <- v). Proof. intros. apply agree_exten with rs. auto. intros. apply Pregmap.gso. congruence. @@ -266,7 +268,7 @@ Qed. Lemma agree_change_sp: forall ms sp rs sp', agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <-- sp'). + agree ms sp' (rs#SP <- sp'). Proof. intros. inv H. split; auto. intros. rewrite Pregmap.gso; auto with asmgen. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8b686676..c996ab1f 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1355,7 +1355,7 @@ Definition noscroll := 0. Ltac bsimpl := unfold exec_bblock; simpl. Lemma Pget_correct: - forall (dst: gpreg) (src: breg) k (rs: regset) m, + forall (dst: gpreg) (src: preg) k (rs: regset) m, src = RA -> exists rs', exec_straight ge fn (Pget dst src ::b k) rs m k rs' m @@ -1365,9 +1365,9 @@ Proof. intros. econstructor; econstructor; econstructor. - rewrite H. bsimpl. auto. - Simpl. -(* - Simpl. +- Simpl. - intros. rewrite H. Simpl. - *)Admitted. +Qed. (* diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v index bd531930..cd29d6b2 100644 --- a/mppa_k1c/Asmbundle.v +++ b/mppa_k1c/Asmbundle.v @@ -47,17 +47,18 @@ Proof. all: repeat ((try (left; reflexivity)); right). Qed. -Definition all_bregs := (map IR all_gpregs) ++ (map FR all_gpregs) ++ (RA::nil). +Definition all_pregs := (map IR all_gpregs) ++ (map FR all_gpregs) ++ (RA::PC::nil). -Fact all_bregs_complete : forall br, List.In br all_bregs. +Fact all_pregs_complete : forall br, List.In br all_pregs. Proof. intros. destruct br. - - unfold all_bregs. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. - - unfold all_bregs. apply in_app_iff. right. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. - - unfold all_bregs. repeat (apply in_app_iff; right). simpl. left; auto. + - unfold all_pregs. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. + - unfold all_pregs. apply in_app_iff. right. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. + - unfold all_pregs. repeat (apply in_app_iff; right). simpl. left; auto. + - unfold all_pregs. repeat (apply in_app_iff; right). simpl. right; auto. Qed. -Definition writeregs (i: instruction): list breg := +Definition writeregs (i: instruction): list preg := match i with (* Control instructions *) | Pset rd rs => rd::nil @@ -77,25 +78,27 @@ Definition writeregs (i: instruction): list breg := | Pallocframe _ _ => IR FP::IR GPR31::IR SP :: nil | Pfreeframe _ _ => IR GPR31::IR SP :: nil (* builtins : only implemented in OCaml, we know nothing about them *) - | Pbuiltin _ _ _ => all_bregs + | Pbuiltin _ _ _ => all_pregs (* Instructions that do not write *) | Pnop | Pret | Pgoto _ | Pj_l _ | Pcb _ _ _ | Pcbu _ _ _ | PStoreRRO _ _ _ _ => nil end. -Lemma update_PC_breg (rs: regset) v (r: breg): - (rs#PC <-- v) r = rs r. +(* Lemma update_PC_breg (rs: regset) v (r: preg): + (rs#PC <- v) r = rs r. Proof. - rewrite Pregmap.gso; congruence. + rewrite Pregmap.gso; auto. congruence. Qed. + *) -Lemma update_pregs_diff (rs:regset) rd x r: r <> rd -> update_pregs rs (rs # rd <- x) r = rs r. +(* Lemma update_pregs_diff (rs:regset) rd x r: r <> rd -> update_pregs rs (rs # rd <- x) r = rs r. Proof. unfold update_pregs. intro H. rewrite Bregmap.gso; congruence. Qed. - -Hint Rewrite update_PC_breg update_pregs_diff: regset_rw. + *) -Fact writeregs_correct f i rs m rs' m' r: +(* Hint Rewrite update_PC_breg update_pregs_diff: regset_rw. *) + +(* Fact writeregs_correct f i rs m rs' m' r: ~(List.In r (writeregs i)) -> (exec_bblock ge f (bblock_single_inst i) rs m) = Next rs' m' -> rs' r = rs r. @@ -121,8 +124,9 @@ Proof. autorewrite with regset_rw; auto. - (* ALLOCFRAME *) Admitted. + *) -Definition readregs (i: instruction) : list breg := +Definition readregs (i: instruction) : list preg := match i with (* Control instructions *) | Pset rd rs => IR rs::nil @@ -141,14 +145,14 @@ Definition readregs (i: instruction) : list breg := (* Alloc and freeframe (from the semantics) *) | Pallocframe _ _ | Pfreeframe _ _ => IR SP :: nil (* builtins : only implemented in OCaml, we know nothing about them *) - | Pbuiltin _ _ _ => all_bregs + | Pbuiltin _ _ _ => all_pregs (* Instructions that do not read *) | Pnop | Pcall _ | Pgoto _ | Pj_l _ | PArithR _ _ | PArithRI32 _ _ _ | PArithRI64 _ _ _ => nil end. Axiom TODO: False. -Definition outcome_equiv (r: breg) v (o1 o2: outcome (rgset:=regset)) := +(* Definition outcome_equiv (r: preg) v (o1 o2: outcome (rgset:=regset)) := match o1 with | Next rs1 m1 => exists rs2, exists m2, o2=Next rs2 m2 /\ (forall r, (rs1#r <-- v) r = rs2 r) /\ (forall chunk p, Mem.loadv chunk m1 p = Mem.loadv chunk m2 p) | Stuck => o2 = Stuck @@ -174,6 +178,7 @@ Proof. rewrite! update_PC_breg. (* TODO: lemma on rs # _ <-- _ *) Abort. + *) (* alternative definition of disjoint *) Definition disjoint_x {A: Type} (l l':list A) : Prop := forall r, In r l -> ~In r l'. (* TODO: use notIn instead ? *) @@ -213,7 +218,7 @@ Proof. repeat (match goal with h:_ \/ _ |- _ => inversion_clear h; [discriminate|] | _ => fail end); contradiction). Qed. -Inductive depfree : list breg -> list breg -> list instruction -> Prop := +Inductive depfree : list preg -> list preg -> list instruction -> Prop := | depfree_nil : forall lr lw, depfree lr lw nil | depfree_cons : forall i lri lwi lw lr l, lri = readregs i -> lwi = writeregs i -> @@ -224,7 +229,7 @@ Inductive depfree : list breg -> list breg -> list instruction -> Prop := . (* une version alternative *) -Inductive depfreex : list breg -> list instruction -> Prop := +Inductive depfreex : list preg -> list instruction -> Prop := | depfreex_nil : forall lw, depfreex lw nil | depfreex_cons : forall i lri lwi lw l, lri = readregs i -> lwi = writeregs i -> -- cgit From f9b7873c679af88533df8ae79468d9a007281fcf Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 26 Sep 2018 17:30:54 +0200 Subject: Enlèvement du "no_builtin" condition; exec_control sur les option control; exec_straight_blocks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 37 ++++++++++----- mppa_k1c/Asmblockgenproof.v | 4 +- mppa_k1c/Asmblockgenproof0.v | 107 ++++++++++++++++++++++++++++++------------- mppa_k1c/Asmblockgenproof1.v | 27 +++++++---- 4 files changed, 120 insertions(+), 55 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index f066a1a2..6411dca5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -386,11 +386,11 @@ Coercion PCtlFlow: cf_instruction >-> control. Definition non_empty_bblock (body: list basic) (exit: option control): Prop := body <> nil \/ exit <> None. (* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type ? *) -Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, +(* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. - + *) Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := - non_empty_bblock body exit /\ builtin_alone body exit. + non_empty_bblock body exit (* /\ builtin_alone body exit *). (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -402,7 +402,7 @@ Record bblock := mk_bblock { correct: wf_bblock header body exit }. -Ltac bblock_auto_correct := (split; try discriminate; try (left; discriminate); try (right; discriminate)). +Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). Local Obligation Tactic := bblock_auto_correct. (* FIXME: redundant with definition in Machblock *) @@ -435,7 +435,7 @@ Qed. Lemma size_positive (b:bblock): size b > 0. Proof. unfold size. apply to_nat_pos. rewrite Nat2Z.id. - destruct b as [h b e COR]. simpl. inversion COR. inversion H. + destruct b as [h b e COR]. simpl. inversion COR. (* inversion H. *) - assert ((length b > 0)%nat). apply length_nonil. auto. omega. - destruct e; simpl; try omega. contradict H; simpl; auto. @@ -486,9 +486,22 @@ Program Definition bblock_single_inst (i: instruction) := | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} end. -Next Obligation. +(* Next Obligation. bblock_auto_correct. Qed. + *) +Program Definition bblock_basic_ctl (c: list basic) (i: option control) := + match i with + | Some i => {| header:=nil; body:=c; exit:=Some i |} + | None => + match c with + | _::_ => {| header:=nil; body:=c; exit:=None |} + | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} + end + end. +Next Obligation. + constructor. subst; discriminate. +Qed. (** * Operational semantics *) @@ -967,7 +980,9 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti we generate cannot use those registers to hold values that must survive the execution of the pseudo-instruction. *) -Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outcome regset := +Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome regset := + match oc with + | Some ic => (** Get/Set system registers *) match ic with @@ -998,16 +1013,14 @@ Definition exec_control (f: function) (ic: control) (rs: regset) (m: mem) : outc (** Pseudo-instructions *) | Pbuiltin ef args res => Stuck (**r treated specially below *) + end + | None => Next rs m end. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := match exec_body (body b) rs0 m with | Next rs' m' => - let rs1 := nextblock b rs' in - match (exit b) with - | None => Next rs1 m' - | Some ic => exec_control f ic rs1 m' - end + let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' | Stuck => Stuck end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 345f71b2..fcc32841 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -17,7 +17,7 @@ Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. (* Require Import Asmgen Asmgenproof0 Asmgenproof1. *) -Require Import Asmblockgen Asmblockgenproof0. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. Module MB := Machblock. Module AB := Asmblock. @@ -1105,7 +1105,7 @@ Proof. set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). destruct TODO. -(* exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. +(* exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) rs2 m2'); auto. intros (rs' & U' & V'). exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). rewrite chunk_of_Tptr in P. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 309dbc2c..971a3afa 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -562,19 +562,17 @@ Variable fn: function. Instructions are taken from the first list instead of being fetched from memory. *) -Inductive exec_straight: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := +Inductive exec_straight: list basic -> regset -> mem -> + list basic -> regset -> mem -> Prop := | exec_straight_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr (rs1 PC) (Ptrofs.repr (size b1)) -> - exec_straight (b1 :: c) rs1 m1 c rs2 m2 + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight (i1 :: c) rs1 m1 c rs2 m2 | exec_straight_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr (rs1 PC) (Ptrofs.repr (size b)) -> + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight (b :: c) rs1 m1 c' rs3 m3. + exec_straight (i :: c) rs1 m1 c' rs3 m3. Lemma exec_straight_trans: forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, @@ -588,37 +586,84 @@ Proof. Qed. Lemma exec_straight_two: - forall b1 b2 c rs1 m1 rs2 m2 rs3 m3, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - exec_bblock ge fn b2 rs2 m2 = Next rs3 m3 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - rs3#PC = Val.offset_ptr rs2#PC (Ptrofs.repr (size b2)) -> - exec_straight (b1 :: b2 :: c) rs1 m1 c rs3 m3. + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> + exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. Proof. intros. apply exec_straight_step with rs2 m2; auto. apply exec_straight_one; auto. Qed. Lemma exec_straight_three: - forall b1 b2 b3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - exec_bblock ge fn b2 rs2 m2 = Next rs3 m3 -> - exec_bblock ge fn b3 rs3 m3 = Next rs4 m4 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - rs3#PC = Val.offset_ptr rs2#PC (Ptrofs.repr (size b2)) -> - rs4#PC = Val.offset_ptr rs3#PC (Ptrofs.repr (size b3)) -> - exec_straight (b1 :: b2 :: b3 :: c) rs1 m1 c rs4 m4. + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> + rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> + rs4#PC = Val.offset_ptr rs3#PC Ptrofs.one -> + exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. Proof. intros. apply exec_straight_step with rs2 m2; auto. eapply exec_straight_two; eauto. Qed. +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +(** Linking exec_straight with exec_straight_blocks *) + +Axiom TODO: False. + +Lemma exec_straight_body: + forall c rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + exec_body ge c rs1 m1 = Next rs2 m2. +Proof. + induction c. + - intros. inv H. + - intros. inv H. + + inv H7. simpl. remember (exec_basic_instr _ _ _ _) as ebi. destruct ebi; simpl; auto. + + destruct TODO. +Qed. + +Lemma exec_straight_through: + forall c i b lb rs1 m1 rs2 m2 rs2' m2' rs3 m3, + 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 rs3 m3 -> + exec_straight_blocks (b::lb) rs1 m1 lb rs3 m3. +Proof. + intros. subst. constructor 1. + - unfold exec_bblock. destruct i. + + simpl body. erewrite exec_straight_body; eauto. + + destruct TODO. + - destruct TODO. +Qed. + (** The following lemmas show that straight-line executions - (predicate [exec_straight]) correspond to correct Asm executions. *) + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) Lemma exec_straight_steps_1: forall c rs m c' rs' m', - exec_straight c rs m c' rs' m' -> + exec_straight_blocks c rs m c' rs' m' -> size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> @@ -628,12 +673,12 @@ Lemma exec_straight_steps_1: Proof. induction 1; intros. apply plus_one. - repeat (econstructor; eauto). + econstructor; econstructor; eauto. eapply find_bblock_tail. eauto. eapply plus_left'. - repeat (econstructor; eauto). + econstructor; econstructor; eauto. eapply find_bblock_tail. eauto. - apply IHexec_straight with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int; auto. @@ -642,7 +687,7 @@ Qed. Lemma exec_straight_steps_2: forall c rs m c' rs' m', - exec_straight c rs m c' rs' m' -> + exec_straight_blocks c rs m c' rs' m' -> size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> forall b ofs, rs#PC = Vptr b ofs -> @@ -656,7 +701,7 @@ Proof. exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. rewrite H0. rewrite H2. auto. apply code_tail_next_int; auto. - apply IHexec_straight with (Ptrofs.add ofs (Ptrofs.repr (size b))). + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int; auto. Qed. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c996ab1f..8ea4cfeb 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1285,16 +1285,18 @@ Proof. unfold exec_load. rewrite B, LOAD. eauto. Simpl. split; intros; Simpl. Qed. +*) +(* Lemma indexed_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) r1 m, + forall chunk (mk_instr: ireg -> offset -> basic) r1 m, (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + exec_bblock ge fn (bblock_single_inst (mk_instr base ofs)) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> + base <> GPR31 -> r1 <> GPR31 -> IR r1 <> PC -> exists rs', - exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' + exec_straight ge fn (indexed_memory_access mk_instr base ofs ::b k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. @@ -1305,7 +1307,9 @@ Proof. unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. intros; Simpl. Qed. +*) +(* Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> @@ -1350,23 +1354,20 @@ Qed. *) -Definition noscroll := 0. - Ltac bsimpl := unfold exec_bblock; simpl. Lemma Pget_correct: forall (dst: gpreg) (src: preg) k (rs: regset) m, src = RA -> exists rs', - exec_straight ge fn (Pget dst src ::b k) rs m k rs' m + exec_straight ge (Pget dst src :: k) rs m k rs' m /\ rs'#dst = rs#src /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. intros. econstructor; econstructor; econstructor. - rewrite H. bsimpl. auto. - Simpl. -- Simpl. -- intros. rewrite H. Simpl. +- intros. Simpl. Qed. (* @@ -1398,19 +1399,25 @@ Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto. Qed. +*) + +(* +Definition noscroll := 0. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> base <> GPR31 -> src <> GPR31 -> exists rs', - exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' + exec_straight ge fn (storeind_ptr src base ofs ::b k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true); auto. Qed. +*) +(* Lemma transl_memory_access_correct: forall mk_instr addr args k c (rs: regset) m v, transl_memory_access mk_instr addr args k = OK c -> -- cgit From 99cb567ffa32366c6d9d7ec5c4f613eac5e71294 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 27 Sep 2018 11:48:44 +0200 Subject: Avancement dans exec_straight_through --- mppa_k1c/Asmblockgenproof0.v | 60 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 51 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 971a3afa..ba2900da 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -629,6 +629,16 @@ Inductive exec_straight_blocks: bblocks -> regset -> mem -> (** 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. + Axiom TODO: False. Lemma exec_straight_body: @@ -643,19 +653,51 @@ Proof. + destruct TODO. Qed. +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). + all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H0. Simpl. discriminate. + destruct rs; try discriminate. inv H1. Simpl. + destruct rd; try discriminate. inv H1; Simpl. + auto. +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_through: - forall c i b lb rs1 m1 rs2 m2 rs2' m2' rs3 m3, + 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 rs3 m3 -> - exec_straight_blocks (b::lb) rs1 m1 lb rs3 m3. -Proof. - intros. subst. constructor 1. - - unfold exec_bblock. destruct i. - + simpl body. erewrite exec_straight_body; eauto. - + destruct TODO. - - destruct TODO. + 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 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) rs1 m1 rs2 m2'); auto. Qed. (** The following lemmas show that straight-line executions -- cgit From 3600b9b62b0deb1c9cc0d3a3d31160144c6aae86 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 27 Sep 2018 17:49:20 +0200 Subject: storeind_ptr_correct un peu d'avancée MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgenproof.v | 7 +++---- mppa_k1c/Asmblockgenproof0.v | 4 +--- mppa_k1c/Asmblockgenproof1.v | 44 +++++++++++++++++++++++++++++--------------- 3 files changed, 33 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index fcc32841..a0238225 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1104,10 +1104,9 @@ Proof. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - destruct TODO. -(* exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + exploit (Pget_correct tge GPR8 RA nil rs2 m2'); auto. + intros (rs' & U' & V'). destruct TODO. +(* exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). rewrite chunk_of_Tptr in P. assert (rs' GPR8 = rs0 RA). { apply V'. } assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index ba2900da..c579cc1a 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -639,8 +639,6 @@ Ltac Simplif := Ltac Simpl := repeat Simplif. -Axiom TODO: False. - Lemma exec_straight_body: forall c rs1 m1 rs2 m2, exec_straight c rs1 m1 nil rs2 m2 -> @@ -650,7 +648,7 @@ Proof. - intros. inv H. - intros. inv H. + inv H7. simpl. remember (exec_basic_instr _ _ _ _) as ebi. destruct ebi; simpl; auto. - + destruct TODO. + + simpl. rewrite H2. apply IHc. auto. Qed. Lemma exec_basic_instr_pc: diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8ea4cfeb..37b1092f 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -57,6 +57,8 @@ Proof. *) Qed. +*) + Lemma make_immed64_sound: forall n, match make_immed64 n with @@ -75,6 +77,8 @@ Proof. auto. Qed. +(* + (** Properties of registers *) Lemma ireg_of_not_GPR31: @@ -312,22 +316,27 @@ Ltac ArgsInv := | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * end). -Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := +*) + +Definition bla := 0. + +Inductive exec_straight_opt: list basic -> regset -> mem -> list basic -> regset -> mem -> Prop := | exec_straight_opt_refl: forall c rs m, exec_straight_opt c rs m c rs m | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, - exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge c1 rs1 m1 c2 rs2 m2 -> exec_straight_opt c1 rs1 m1 c2 rs2 m2. Remark exec_straight_opt_right: forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> - exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> - exec_straight ge fn c1 rs1 m1 c3 rs3 m3. + exec_straight ge c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge c1 rs1 m1 c3 rs3 m3. Proof. destruct 1; intros. auto. eapply exec_straight_trans; eauto. Qed. +(* Lemma transl_comp_correct: forall cmp r1 r2 lbl k rs m b, exists rs', @@ -1218,12 +1227,15 @@ Qed. (** Memory accesses *) +*) + +Definition no := 0. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, base <> GPR31 -> exists base' ofs' rs', - exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m + exec_straight_opt (indexed_memory_access mk_instr base ofs :: k) rs m (mk_instr base' ofs' :: k) rs' m /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. @@ -1265,6 +1277,7 @@ Proof. *)*) Qed. +(* Lemma indexed_load_access_correct: forall chunk (mk_instr: ireg -> offset -> instruction) rd m, (forall base ofs rs, @@ -1287,27 +1300,28 @@ Proof. Qed. *) -(* +Definition noscroll := 0. + Lemma indexed_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) r1 m, (forall base ofs rs, - exec_bblock ge fn (bblock_single_inst (mk_instr base ofs)) rs m = exec_store ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> base <> GPR31 -> r1 <> GPR31 -> IR r1 <> PC -> exists rs', - exec_straight ge fn (indexed_memory_access mk_instr base ofs ::b k) rs m k rs' m' + exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. +(* intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & A & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. intros; Simpl. -Qed. -*) + *)Admitted. + (* Lemma loadind_correct: @@ -1401,21 +1415,21 @@ Proof. Qed. *) -(* -Definition noscroll := 0. + +Definition nosroll := 0. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> base <> GPR31 -> src <> GPR31 -> exists rs', - exec_straight ge fn (storeind_ptr src base ofs ::b k) rs m k rs' m' + exec_straight ge (storeind_ptr src base ofs :: k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true); auto. Qed. -*) + (* Lemma transl_memory_access_correct: -- cgit From 27045947a8934d90e1d880ddc37b79c6537ff523 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 28 Sep 2018 16:25:01 +0200 Subject: Preuve du internal_function (step_simulation) --- mppa_k1c/Asmblockgenproof.v | 58 ++++++++++++++++++++++++++------------------ mppa_k1c/Asmblockgenproof0.v | 55 +++++++++++++++++++++++++++++++++++------ mppa_k1c/Asmblockgenproof1.v | 13 +++++----- 3 files changed, 90 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index a0238225..7b557b54 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -55,7 +55,6 @@ Lemma functions_translated: 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) -> @@ -65,7 +64,7 @@ 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: @@ -1105,38 +1104,48 @@ Proof. set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). exploit (Pget_correct tge GPR8 RA nil rs2 m2'); auto. - intros (rs' & U' & V'). destruct TODO. -(* exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + 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) GPR8 nil rs'' m2'). rewrite chunk_of_Tptr in P. assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. } assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - rewrite H3. rewrite H4. + assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. } + rewrite H4. rewrite H3. rewrite H6. rewrite H5. (* change (rs' GPR8) with (rs0 RA). *) rewrite ATLR. change (rs2 GPR12) with sp. eexact P. congruence. congruence. intros (rs3 & U & V). + exploit (exec_straight_through_singleinst); eauto. + intro W. + remember (nextblock _ rs3) as rs3'. assert (EXEC_PROLOGUE: - exec_straight tge tf - tf.(fn_code) rs0 m' - x0 rs3 m3'). - { change (fn_code tf) with tfbody; unfold tfbody. - apply exec_straight_step with rs2 m2'. - unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3'). + { change (fn_blocks tf) with tfbody; unfold tfbody. + apply exec_straight_blocks_step with rs2 m2'. + unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity. reflexivity. - eapply exec_straight_trans. - - eexact U'. - - eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + eapply exec_straight_blocks_trans. + - eexact W'. + - eexact W. } + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor. intros (ofs' & X & Y). - left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. + constructor. econstructor; eauto. rewrite X; econstructor; eauto. apply agree_exten with rs2; eauto with asmgen. unfold rs2. - apply agree_nextinstr. apply agree_set_other; auto with asmgen. + apply agree_nextblock. 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. @@ -1145,17 +1154,18 @@ Local Transparent destroyed_at_function_entry. intros. assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite V. + rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto. assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H6; auto. + (* 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. - intros. rewrite V by auto with asmgen. + auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen. assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite Heqrs''. Simpl. rewrite H4 by auto with asmgen. reflexivity. - *) - (* external function *) + - (* external function *) exploit functions_translated; eauto. intros [tf [A B]]. simpl in B. inv B. exploit extcall_arguments_match; eauto. @@ -1175,6 +1185,8 @@ Local Transparent destroyed_at_function_entry. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. +Unshelve. + destruct TODO. Qed. Lemma transf_initial_states: diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index c579cc1a..ac2e77e4 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -90,6 +90,26 @@ Proof. intros. apply nextblock_inv. red; intro; subst; discriminate. Qed. +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + (** * Agreement between Mach registers and processor registers *) Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { @@ -181,13 +201,12 @@ Proof. intros. apply Pregmap.gso. congruence. Qed. -(* Lemma agree_nextinstr: - forall ms sp rs, - agree ms sp rs -> agree ms sp (nextinstr rs). +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). Proof. - intros. unfold nextinstr. apply agree_set_other. auto. auto. + intros. unfold nextblock. apply agree_set_other. auto. auto. Qed. - *) Lemma agree_set_pair: forall sp p v v' ms rs, @@ -214,7 +233,7 @@ Proof. intros. apply H0; auto. Qed. -(* Lemma agree_undef_regs: +Lemma agree_undef_regs: forall ms sp rl rs rs', agree ms sp rs -> (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> @@ -230,7 +249,6 @@ Proof. rewrite preg_notin_charact. intros; red; intros. elim n. exploit preg_of_injective; eauto. congruence. Qed. - *) (* Lemma agree_undef_regs2: forall ms sp rl rs rs', @@ -627,6 +645,17 @@ Inductive exec_straight_blocks: bblocks -> regset -> mem -> exec_straight_blocks c rs2 m2 c' rs3 m3 -> exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + (** Linking exec_straight with exec_straight_blocks *) Ltac Simplif := @@ -698,6 +727,18 @@ Proof. + rewrite <- (exec_straight_pc (i ::i c) rs1 m1 rs2 m2'); auto. Qed. +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a::nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. auto. + simpl; auto. unfold nextblock; 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. *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 37b1092f..81123c9b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1313,14 +1313,15 @@ Lemma indexed_store_access_correct: exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. -(* intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. - exploit indexed_memory_access_correct; eauto. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + exploit indexed_memory_access_correct. instantiate (1 := base). eauto. intros (base' & ofs' & rs' & A & B & C). econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. - intros; Simpl. - *)Admitted. + eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. + unfold exec_store. rewrite B, C, STORE. eauto. eauto. + destruct r1; try discriminate. contradiction NOT31'. auto. auto. +(* intros; Simpl. *) +Qed. (* -- cgit From 3482cce97fd40de8f2c34eaaf642a54a9f453b83 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 28 Sep 2018 17:02:56 +0200 Subject: Removed the bundle attempt --- mppa_k1c/Asmblock.v | 54 +---- mppa_k1c/Asmblockgenproof0.v | 4 +- mppa_k1c/Asmbundle.v | 456 ------------------------------------------- mppa_k1c/Asmbundling.v | 23 --- mppa_k1c/Asmbundlingproof.v | 95 --------- 5 files changed, 9 insertions(+), 623 deletions(-) delete mode 100644 mppa_k1c/Asmbundle.v delete mode 100644 mppa_k1c/Asmbundling.v delete mode 100644 mppa_k1c/Asmbundlingproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 6411dca5..51010c43 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1087,15 +1087,15 @@ Inductive state: Type := * Perhaps there is a way to avoid that ? *) -Inductive stepin: option bblock -> state -> trace -> state -> Prop := - | exec_stepin_internal: +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: forall b ofs f bi rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> exec_bblock f bi rs m = Next rs' m' -> - stepin (Some bi) (State rs m) E0 (State rs' m') - | exec_stepin_builtin: + step (State rs m) E0 (State rs' m') + | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' bi, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> @@ -1107,47 +1107,9 @@ Inductive stepin: option bblock -> state -> trace -> state -> Prop := (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs#GPR31 <- Vundef))) -> - stepin (Some bi) (State rs m) t (State rs' m') - | exec_stepin_external: + step (State rs m) t (State rs' m') + | exec_step_external: forall b ef args res rs m t rs' m', - rs PC = Vptr b Ptrofs.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - external_call ef ge args m t res m' -> - extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> - stepin None (State rs m) t (State rs' m') - . - -Definition step (s:state) (t:trace) (s':state): Prop := exists obi, stepin obi s t s'. - -(* original constructors *) -Lemma exec_step_internal b ofs f bi rs m rs' m': - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> - exec_bblock f bi rs m = Next rs' m' -> - step (State rs m) E0 (State rs' m'). -Proof. - intros; eexists. eapply exec_stepin_internal; eauto. -Qed. - -Lemma exec_step_builtin b ofs f ef args res rs m vargs t vres rs' m' bi: - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> - exit bi = Some (PExpand (Pbuiltin ef args res)) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = nextblock bi - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <- Vundef))) -> - step (State rs m) t (State rs' m'). -Proof. - intros; eexists. eapply exec_stepin_builtin; eauto. -Qed. - -Lemma exec_step_external b ef args res rs m t rs' m': rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> @@ -1155,9 +1117,7 @@ Lemma exec_step_external b ef args res rs m t rs' m': rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> step (State rs m) t (State rs' m') . -Proof. - intros; eexists. eapply exec_stepin_external; eauto. -Qed. + End RELSEM. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index ac2e77e4..3b3ac165 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -754,10 +754,10 @@ Lemma exec_straight_steps_1: Proof. induction 1; intros. apply plus_one. - econstructor; econstructor; eauto. + econstructor; eauto. eapply find_bblock_tail. eauto. eapply plus_left'. - econstructor; econstructor; eauto. + econstructor; eauto. eapply find_bblock_tail. eauto. apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). auto. rewrite H0. rewrite H3. reflexivity. diff --git a/mppa_k1c/Asmbundle.v b/mppa_k1c/Asmbundle.v deleted file mode 100644 index cd29d6b2..00000000 --- a/mppa_k1c/Asmbundle.v +++ /dev/null @@ -1,456 +0,0 @@ -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Export Asmblock. -Require Import ListSet. - - -Fixpoint notIn {A} (x: A) (l:list A): Prop := - match l with - | nil => True - | a::l' => x <> a /\ notIn x l' - end. - -Lemma notIn_rewrite A (r:A) l: (~List.In r l) <-> notIn r l. -Proof. - induction l; simpl; intuition. -Qed. - - -Section RELSEM. - -Variable ge: genv. - -(** List of all registers, to use for Pbuiltin dependencies *) -Definition all_gpregs := - GPR0 :: GPR1 :: GPR2 :: GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: - GPR10 :: GPR11 :: GPR12 :: GPR13 :: GPR14 :: GPR15 :: GPR16 :: GPR17 :: GPR18 :: GPR19 :: - GPR20 :: GPR21 :: GPR22 :: GPR23 :: GPR24 :: GPR25 :: GPR26 :: GPR27 :: GPR28 :: GPR29 :: - GPR30 :: GPR31 :: GPR32 :: GPR33 :: GPR34 :: GPR35 :: GPR36 :: GPR37 :: GPR38 :: GPR39 :: - GPR40 :: GPR41 :: GPR42 :: GPR43 :: GPR44 :: GPR45 :: GPR46 :: GPR47 :: GPR48 :: GPR49 :: - GPR50 :: GPR51 :: GPR52 :: GPR53 :: GPR54 :: GPR55 :: GPR56 :: GPR57 :: GPR58 :: GPR59 :: - GPR60 :: GPR61 :: GPR62 :: GPR63 :: nil. - -Fact all_gpregs_complete : forall gpr, List.In gpr all_gpregs. -Proof. - intros. destruct gpr; simpl. - all: repeat ((try (left; reflexivity)); right). -Qed. - -Definition all_pregs := (map IR all_gpregs) ++ (map FR all_gpregs) ++ (RA::PC::nil). - -Fact all_pregs_complete : forall br, List.In br all_pregs. -Proof. - intros. destruct br. - - unfold all_pregs. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. - - unfold all_pregs. apply in_app_iff. right. apply in_app_iff. left. apply in_map. apply all_gpregs_complete. - - unfold all_pregs. repeat (apply in_app_iff; right). simpl. left; auto. - - unfold all_pregs. repeat (apply in_app_iff; right). simpl. right; auto. -Qed. - -Definition writeregs (i: instruction): list preg := - match i with - (* Control instructions *) - | Pset rd rs => rd::nil - | Pget rd rs => IR rd::nil - | Pcall s => RA::nil - (* Load *) - | PLoadRRO i rd ra o => IR rd::nil - (* Arith *) - | PArithR i rd => IR rd::nil - | PArithRR i rd rs => IR rd::nil - | PArithRI32 i rd imm => IR rd::nil - | PArithRI64 i rd imm => IR rd::nil - | PArithRRR i rd rs1 rs2 => IR rd::nil - | PArithRRI32 i rd rs imm => IR rd::nil - | PArithRRI64 i rd rs imm => IR rd::nil - (* Alloc and freeframe *) - | Pallocframe _ _ => IR FP::IR GPR31::IR SP :: nil - | Pfreeframe _ _ => IR GPR31::IR SP :: nil - (* builtins : only implemented in OCaml, we know nothing about them *) - | Pbuiltin _ _ _ => all_pregs - (* Instructions that do not write *) - | Pnop | Pret | Pgoto _ | Pj_l _ | Pcb _ _ _ | Pcbu _ _ _ | PStoreRRO _ _ _ _ => nil - end. - -(* Lemma update_PC_breg (rs: regset) v (r: preg): - (rs#PC <- v) r = rs r. -Proof. - rewrite Pregmap.gso; auto. congruence. -Qed. - *) - -(* Lemma update_pregs_diff (rs:regset) rd x r: r <> rd -> update_pregs rs (rs # rd <- x) r = rs r. -Proof. - unfold update_pregs. intro H. rewrite Bregmap.gso; congruence. -Qed. - *) - -(* Hint Rewrite update_PC_breg update_pregs_diff: regset_rw. *) - -(* Fact writeregs_correct f i rs m rs' m' r: - ~(List.In r (writeregs i)) -> - (exec_bblock ge f (bblock_single_inst i) rs m) = Next rs' m' -> - rs' r = rs r. -Proof. - rewrite notIn_rewrite. - unfold exec_bblock, nextblock, size; destruct i; simpl. - destruct i; simpl. - destruct i; simpl; try ( - destruct i; simpl; intro H; decompose [and] H; clear H; - intros H; inversion_clear H; - autorewrite with regset_rw; auto; fail). - - (* LOAD *) destruct i; simpl. - destruct i; simpl; unfold exec_load; - destruct (Mem.loadv _ _ _); try discriminate; - intro H; decompose [and] H; clear H; - intros H; inversion_clear H; - autorewrite with regset_rw; auto. - - (* STORE *) destruct i; simpl. - destruct i; simpl; unfold exec_store; - destruct (Mem.storev _ _ _ _); try discriminate; - intro H; clear H; - intros H; inversion_clear H; - autorewrite with regset_rw; auto. - - (* ALLOCFRAME *) -Admitted. - *) - -Definition readregs (i: instruction) : list preg := - match i with - (* Control instructions *) - | Pset rd rs => IR rs::nil - | Pget rd rs => rs::nil - | Pcb bt r l => IR r::nil - | Pcbu bt r l => IR r::nil - | Pret => RA::nil - (* Load and store *) - | PLoadRRO i rd ra o => IR ra :: nil - | PStoreRRO i rs ra o => IR rs :: IR ra :: nil - (* Arith *) - | PArithRR i rd rs => IR rs :: nil - | PArithRRR i rd rs1 rs2 => IR rs1 :: IR rs2 :: nil - | PArithRRI32 i rd rs imm => IR rs :: nil - | PArithRRI64 i rd rs imm => IR rs :: nil - (* Alloc and freeframe (from the semantics) *) - | Pallocframe _ _ | Pfreeframe _ _ => IR SP :: nil - (* builtins : only implemented in OCaml, we know nothing about them *) - | Pbuiltin _ _ _ => all_pregs - (* Instructions that do not read *) - | Pnop | Pcall _ | Pgoto _ | Pj_l _ | PArithR _ _ | PArithRI32 _ _ _ | PArithRI64 _ _ _ => nil - end. - -Axiom TODO: False. - -(* Definition outcome_equiv (r: preg) v (o1 o2: outcome (rgset:=regset)) := - match o1 with - | Next rs1 m1 => exists rs2, exists m2, o2=Next rs2 m2 /\ (forall r, (rs1#r <-- v) r = rs2 r) /\ (forall chunk p, Mem.loadv chunk m1 p = Mem.loadv chunk m2 p) - | Stuck => o2 = Stuck - end. - -Fact useregs_correct f i rs m r v: - ~(List.In r ((readregs i)++(writeregs i))) -> - outcome_equiv r v - (exec_bblock ge f (bblock_single_inst i) rs m) - (exec_bblock ge f (bblock_single_inst i) (rs#r <-- v) m). -Proof. - rewrite notIn_rewrite. - unfold exec_bblock, nextblock, size; destruct i; simpl. - + destruct i; simpl. - - destruct i; simpl. - * intro H; decompose [and] H; clear H. (* H useless *) - elim TODO. - * intro H; decompose [and] H; clear H. - destruct i; simpl. - simpl; eexists; eexists; constructor 1; eauto. - intuition. - destruct r0. - rewrite! update_PC_breg. - (* TODO: lemma on rs # _ <-- _ *) -Abort. - *) - -(* alternative definition of disjoint *) -Definition disjoint_x {A: Type} (l l':list A) : Prop := forall r, In r l -> ~In r l'. (* TODO: use notIn instead ? *) - -Example disjoint_x_ex1: disjoint_x (4::2::1::nil) (3::5::7::nil). -Proof. - unfold disjoint_x; simpl. intuition. -Qed. - -Lemma disjoint_x_nilr : forall A (l:list A), disjoint_x l nil. -Proof. - unfold disjoint_x; simpl. intuition. -Qed. - -Lemma disjoint_x_consl : forall A l l' (e:A), disjoint_x l l' -> (~ In e l') -> disjoint_x (e::l) l'. -Proof. - unfold disjoint_x; simpl. intuition (subst; eauto). -Qed. - -(* Inductive definition of disjoint, easier to reason with - -Sylvain: I am not sure. Actually, from the above definition, we can still prove the following "constructors" as lemma if needed - (cf. example above). -*) - -Inductive disjoint {A: Type} : list A -> list A -> Prop := - | disjoint_nilr : forall l, disjoint l nil - | disjoint_nill : forall l, disjoint nil l - | disjoint_consl : forall l l' e, disjoint l l' -> (~ In e l') -> disjoint (e::l) l' - | disjoint_consr : forall l l' e, disjoint l l' -> (~ In e l) -> disjoint l (e::l') - . - -Example disjoint_ex1: disjoint (4::2::1::nil) (3::5::7::nil). -Proof. - repeat constructor. - all: try (intro H; simpl in H; - repeat (match goal with h:_ \/ _ |- _ => inversion_clear h; [discriminate|] | _ => fail end); contradiction). -Qed. - -Inductive depfree : list preg -> list preg -> list instruction -> Prop := - | depfree_nil : forall lr lw, depfree lr lw nil - | depfree_cons : forall i lri lwi lw lr l, - lri = readregs i -> lwi = writeregs i -> - disjoint lwi lw -> (* Checking for WAW *) - disjoint lri lw -> (* Checking for RAW *) - depfree (lr++lri) (lw++lwi) l -> - depfree lr lw (i::l) - . - -(* une version alternative *) -Inductive depfreex : list preg -> list instruction -> Prop := - | depfreex_nil : forall lw, depfreex lw nil - | depfreex_cons : forall i lri lwi lw l, - lri = readregs i -> lwi = writeregs i -> - disjoint_x lri lw -> (* Checking for RAW *) - disjoint_x lwi lw -> (* Checking for WAW *) - depfreex (lw++lwi) l -> - depfreex lw (i::l) - . - -Import ListNotations. - -Open Scope list_scope. - -Local Hint Resolve depfreex_nil depfreex_cons. - -Example depfreex_2 i1 i2 lw1 lr2 lw2: - lw1 = writeregs i1 -> - lr2 = readregs i2 -> - lw2 = writeregs i2 -> - disjoint_x lr2 lw1 -> (* RAW *) - disjoint_x lw2 lw1 -> (* WAW *) - depfreex [] [i1;i2]. -Proof. - intros; eapply depfreex_cons; eauto; - unfold disjoint_x; simpl; intuition. -Qed. - -(* FIXME: STUB *) -Definition is_bundle (b:bblock):=True. - -Definition bundle_step (s:state) (t:trace) (s':state): Prop := - exists obi, stepin ge obi s t s' /\ forall bi, obi = Some bi -> is_bundle bi. - -End RELSEM. - -Definition bundle_semantics (p: program) := - Semantics bundle_step (initial_state p) final_state (Genv.globalenv p). - - - -(* - -(** * Instruction dependencies, definition of a bundle - -*) - -(** NOTE: in all of these dependencies definitions, we do *not* consider PC. - PC dependencies are fullfilled by the above separation in bblocks - *) - -(* (writereg i rd) holds if an instruction writes to a single register rd *) -Inductive writereg: instruction -> preg -> Prop := - | writereg_set: forall rd rs, writereg (Pset rd rs) rd - | writereg_get: forall rd rs, writereg (Pget rd rs) rd - | writereg_load: forall i rd ra o, writereg (PLoadRRO i rd ra o) rd - | writereg_arith_r: forall i rd, writereg (PArithR i rd) rd - | writereg_arith_rr: forall i rd rs, writereg (PArithRR i rd rs) rd - | writereg_arith_ri32: forall i rd imm, writereg (PArithRI32 i rd imm) rd - | writereg_arith_ri64: forall i rd imm, writereg (PArithRI64 i rd imm) rd - | writereg_arith_rrr: forall i rd rs1 rs2, writereg (PArithRRR i rd rs1 rs2) rd - | writereg_arith_rri32: forall i rd rs imm, writereg (PArithRRI32 i rd rs imm) rd - | writereg_arith_rri64: forall i rd rs imm, writereg (PArithRRI64 i rd rs imm) rd - . - -(* (nowrite i) holds if an instruction doesn't write to any register *) -Inductive nowrite: instruction -> Prop := - | nowrite_ret: nowrite Pret - | nowrite_call: forall l, nowrite (Pcall l) - | nowrite_goto: forall l, nowrite (Pgoto l) - | nowrite_jl: forall l, nowrite (Pj_l l) - | nowrite_cb: forall bt r l, nowrite (Pcb bt r l) - | nowrite_cbu: forall bt r l, nowrite (Pcbu bt r l) - | nowrite_store: forall i rs ra o, nowrite (PStoreRRO i rs ra o) - | nowrite_label: forall l, nowrite (Plabel l) - . - -(* (readregs i lr) holds if an instruction reads from the register list lr, and only from it *) -Inductive readregs: instruction -> list preg -> Prop := - | readregs_set: forall rd rs, readregs (Pset rd rs) (IR rs::nil) - | readregs_get: forall rd rs, readregs (Pget rd rs) (rs::nil) - | readregs_cb: forall bt r l, readregs (Pcb bt r l) (IR r::nil) - | readregs_cbu: forall bt r l, readregs (Pcbu bt r l) (IR r::nil) - | readregs_load: forall i rd ra o, readregs (PLoadRRO i rd ra o) (IR ra::nil) - | readregs_store: forall i rs ra o, readregs (PStoreRRO i rs ra o) (IR rs::IR ra::nil) - | readregs_arith_rr: forall i rd rs, readregs (PArithRR i rd rs) (IR rs::nil) - | readregs_arith_rrr: forall i rd rs1 rs2, readregs (PArithRRR i rd rs1 rs2) (IR rs1::IR rs2::nil) - | readregs_arith_rri32: forall i rd rs imm, readregs (PArithRRI32 i rd rs imm) (IR rs::nil) - | readregs_arith_rri64: forall i rd rs imm, readregs (PArithRRI64 i rd rs imm) (IR rs::nil) - . - -(* (noread i) holds if an instruction doesn't read any register *) -Inductive noread: instruction -> Prop := - | noread_ret: noread Pret - | noread_call: forall l, noread (Pcall l) - | noread_goto: forall l, noread (Pgoto l) - | noread_jl: forall l, noread (Pj_l l) - | noread_arith_r: forall i rd, noread (PArithR i rd) - | noread_arith_ri32: forall i rd imm, noread (PArithRI32 i rd imm) - | noread_arith_ri64: forall i rd imm, noread (PArithRI64 i rd imm) - | noread_label: forall l, noread (Plabel l) - . - -(* (wawfree i i') holds if i::i' has no WAW dependency *) -Inductive wawfree: instruction -> instruction -> Prop := - | wawfree_write: forall i rs i' rs', - writereg i rs -> writereg i' rs' -> rs <> rs' -> wawfree i i' - | wawfree_free1: forall i i', - nowrite i -> wawfree i i' - | wawfree_free2: forall i i', - nowrite i' -> wawfree i i' - . - -(* (rawfree i i') holds if i::i' has no RAW dependency *) -Inductive rawfree: instruction -> instruction -> Prop := - | rawfree_single: forall i rd i' rs, - writereg i rd -> readregs i' (rs::nil) -> rd <> rs -> rawfree i i' - | rawfree_double: forall i rd i' rs rs', - writereg i rd -> readregs i' (rs::rs'::nil) -> rd <> rs -> rd <> rs' -> rawfree i i' - | rawfree_free1: forall i i', - nowrite i -> rawfree i i' - | rawfree_free2: forall i i', - noread i' -> rawfree i i' - . - -(* (depfree i i') holds if i::i' has no RAW or WAW dependency *) -Inductive depfree: instruction -> instruction -> Prop := - | mk_depfree: forall i i', rawfree i i' -> wawfree i i' -> depfree i i'. - -(* (depfreelist i c) holds if i::c has no RAW or WAW dependency _in regards to i_ *) -Inductive depfreelist: instruction -> list instruction -> Prop := - | depfreelist_nil: forall i, - depfreelist i nil - | depfreelist_cons: forall i i' l, - depfreelist i l -> depfree i i' -> depfreelist i (i'::l) - . - -(* (depfreeall c) holds if c has no RAW or WAW dependency within itself *) -Inductive depfreeall: list instruction -> Prop := - | depfreeall_nil: - depfreeall nil - | depfreeall_cons: forall i l, - depfreeall l -> depfreelist i l -> depfreeall (i::l) - . - -(** NOTE: we do not verify the resource constraints of the bundles, - since not meeting them causes a failure when invoking the assembler *) - -(* A bundle is well formed if his body and exit do not have RAW or WAW dependencies *) -Inductive wf_bundle: bblock -> Prop := - | mk_wf_bundle: forall b, depfreeall (body b ++ unfold_exit (exit b)) -> wf_bundle b. - -Hint Constructors writereg nowrite readregs noread wawfree rawfree depfree depfreelist depfreeall wf_bundle. - -Record bundle := mk_bundle { - bd_block: bblock; - bd_correct: wf_bundle bd_block -}. - -Definition bundles := list bundle. - -Definition unbundlize (lb: list bundle) := map bd_block lb. -Definition unfold_bd (lb: list bundle) := unfold (map bd_block lb). - -Lemma unfold_bd_app: forall l l', unfold_bd (l ++ l') = unfold_bd l ++ unfold_bd l'. -Proof. - intros l l'. unfold unfold_bd. rewrite map_app. rewrite unfold_app. auto. -Qed. - -(** Some theorems on bundles construction *) -Lemma bundle_empty_correct: wf_bundle empty_bblock. -Proof. - constructor. auto. -Qed. - -Definition empty_bundle := {| bd_block := empty_bblock; bd_correct := bundle_empty_correct |}. - -(** Bundlization. For now, we restrict ourselves to bundles containing 1 instruction *) - -Definition single_inst_block (i: instruction) := acc_block i empty_bblock. - -Fact single_inst_block_correct: forall i, wf_bundle (hd empty_bblock (single_inst_block i)). -Proof. - intros i. unfold single_inst_block. unfold acc_block. destruct i. - all: simpl; constructor; simpl; auto. -Qed. - -Definition bundlize_inst (i: instruction) := - {| bd_block := hd empty_bblock (single_inst_block i); bd_correct := single_inst_block_correct i |}. - -Lemma bundlize_inst_conserv: forall c, unfold (unbundlize (map bundlize_inst c)) = c. -Proof. - induction c as [|i c]; simpl; auto. - rewrite IHc. destruct i; simpl; auto. -Qed. - -Definition split_bblock (b: bblock) := map bundlize_inst (unfold_block b). - -Fixpoint bundlize (lb: list bblock) := - match lb with - | nil => nil - | b :: lb => split_bblock b ++ bundlize lb - end. - -Lemma unfold_split_bblock: forall b, unfold_bd (split_bblock b) = unfold_block b. -Proof. - intros b. unfold unfold_bd. unfold split_bblock. apply bundlize_inst_conserv. -Qed. - -Theorem unfold_bundlize: forall lb, unfold_bd (bundlize lb) = unfold lb. -Proof. - induction lb as [|b lb]; simpl; auto. - rewrite unfold_bd_app. rewrite IHlb. rewrite unfold_split_bblock. auto. -Qed. - -Theorem unfold_bundlize_fold: forall c, unfold_bd (bundlize (fold c)) = c. -Proof. - intros. rewrite unfold_bundlize. rewrite unfold_fold. auto. -Qed. - -Record function : Type := mkfunction { fn_sig: signature; fn_bundles: bundles }. -Definition fn_code := (fun (f: function) => unfold_bd (fn_bundles f)). -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -*) \ No newline at end of file diff --git a/mppa_k1c/Asmbundling.v b/mppa_k1c/Asmbundling.v deleted file mode 100644 index a7c1b81e..00000000 --- a/mppa_k1c/Asmbundling.v +++ /dev/null @@ -1,23 +0,0 @@ -Require Archi. -Require Import Coqlib Errors. -Require Import AST Integers Floats Memdata. -Require Import Op Locations Asmblock Asmbundle. - -Local Open Scope string_scope. -Local Open Scope error_monad_scope. - -(* FIXME: STUB *) - -Definition transl_blocks (lb: Asmblock.bblocks): res Asmblock.bblocks := - OK lb -. - -Definition transf_function (f: Asmblock.function) := - do lb <- transl_blocks f.(Asmblock.fn_blocks); - OK (mkfunction f.(Asmblock.fn_sig) lb). - -Definition transf_fundef (f: Asmblock.fundef) : res Asmblock.fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: Asmblock.program) : res Asmblock.program := - transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmbundlingproof.v b/mppa_k1c/Asmbundlingproof.v deleted file mode 100644 index 33066786..00000000 --- a/mppa_k1c/Asmbundlingproof.v +++ /dev/null @@ -1,95 +0,0 @@ - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Conventions Asmblock. -Require Import Asmbundle Asmbundling. - -Definition match_prog (p: program) (tp: 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: Asmblock.program. -Variable tprog: Asmblock.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. inv H0; auto. -Qed. - -(* Aargh: harder to prove than expected ! *) -Lemma stepi_simulation obi s1 t s2: stepin ge obi s1 t s2 -> stepin tge obi s1 t s2. -Admitted. - - -(* FIXME: generalize to forward_simulation_plus *) -Theorem step_simulation s1 t s2: step ge s1 t s2 -> bundle_step tge s1 t s2. -Proof. - intros (obi & H). - exists obi. constructor 1. - - apply stepi_simulation; auto. - - unfold is_bundle; auto. -Qed. - - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> exists st2, initial_state tprog st2 /\ st1 = st2. -Proof. - intros st1 H. - inversion H. unfold ge0 in *. - econstructor 1; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero). - econstructor; eauto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite! symbols_preserved. - auto. -Qed. - -Local Hint Resolve step_simulation. - -Theorem transf_program_correct: - forward_simulation (semantics prog) (bundle_semantics tprog). -Proof. - (* FIXME: in general forward_simulation_plus *) - eapply forward_simulation_step. - - apply senv_preserved. - - eexact transf_initial_states. - - intros; subst; simpl; auto. - - intros; subst; simpl in * |- *; eauto. -Qed. - -End PRESERVATION. -- cgit From 028a9a1a4ee8e79585a7123c72ffcc2bb6d94570 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 28 Sep 2018 17:08:58 +0200 Subject: Fixed BaR mentions in the ML files --- mppa_k1c/Asmexpand.ml | 11 ++++------- mppa_k1c/TargetPrinter.ml | 12 +++--------- 2 files changed, 7 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index bb3baf31..13869268 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -419,11 +419,11 @@ let expand_builtin_inline name args res = let open Asmblock in | "__builtin_membar", [], _ -> () (* Vararg stuff *) - | "__builtin_va_start", [BA(BaR (IR a))], _ -> + | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a - | "__builtin_clzll", [BA(BaR (IR a))], BR(BaR (IR res)) -> + | "__builtin_clzll", [BA(IR a)], BR(IR res) -> emit (Pclzll(res, a)) - | "__builtin_k1_stsud", [BA(BaR (IR a1)); BA(BaR (IR a2))], BR(BaR (IR res)) -> + | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pstsud(res, a1, a2)) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> @@ -548,13 +548,10 @@ let int_reg_to_dwarf = let open Asmblock in function | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 -let breg_to_dwarf = let open Asmblock in function +let preg_to_dwarf = let open Asmblock in function | IR r -> int_reg_to_dwarf r | FR r -> int_reg_to_dwarf r | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) - -let preg_to_dwarf = let open Asmblock in function - | BaR r -> breg_to_dwarf r | _ -> assert false let expand_function id fn = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ec579bf9..143b7622 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -62,22 +62,16 @@ module Target : TARGET = let ireg = ireg - let breg oc = let open Asmblock in function + let preg oc = let open Asmblock in function | IR r -> ireg oc r | FR r -> ireg oc r | RA -> output_string oc "$ra" + | _ -> assert false - let breg_annot = let open Asmblock in function + let preg_annot = let open Asmblock in function | IR r -> int_reg_name r | FR r -> int_reg_name r | RA -> "$ra" - - let preg oc = let open Asmblock in function - | BaR r -> breg oc r - | _ -> assert false - - let preg_annot = let open Asmblock in function - | BaR r -> breg_annot r | _ -> assert false (* Names of sections *) -- cgit From e1b3b2291debb78797c724a9469001bc8cc10a15 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 1 Oct 2018 18:06:59 +0200 Subject: SelectLong.vp fix --- mppa_k1c/SelectLong.vp | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index b3e07bf5..26735c99 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -292,14 +292,10 @@ Definition notl (e: expr) := (** ** Integer division and modulus *) -Definition divlu_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil). -Definition modlu_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil). -Definition divls_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil). -Definition modls_base (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil). +Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. +Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. +Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. +Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. Definition shrxlimm (e: expr) (n: int) := if Archi.splitlong then SplitLong.shrxlimm e n else -- cgit From 1a3049e8f60c3c9e9ea0209db89d20d1465c3bc0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 1 Oct 2018 18:07:13 +0200 Subject: Separation de step_simulation_bblock en step_simu_control et step_simu_basic --- mppa_k1c/Asmblockgenproof.v | 67 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 62 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 7b557b54..cafc5dfc 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -548,7 +548,8 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (ATPC: rs PC = parent_ra s), match_states (Machblock.Returnstate s ms m) (Asmblock.State rs m'). -(* + +(* Lemma exec_straight_steps: forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, match_stack ge s -> @@ -570,7 +571,9 @@ Proof. eapply exec_straight_exec; eauto. econstructor; eauto. eapply exec_straight_at; eauto. Qed. +*) +(* Lemma exec_straight_steps_goto: forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', match_stack ge s -> @@ -1073,17 +1076,69 @@ Definition measure (s: MB.state) : nat := Axiom TODO: False. +Lemma step_simulation_control: + forall (bb: Machblock.bblock) sf f sp bb c rs' m' t s' (S1' S2': state), + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb::c) rs' m') t s' -> + match_states (Machblock.State sf f sp (bb :: c) rs' m') S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states s' S2'. +Proof. +Admitted. + +Definition remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma step_simulation_body: + forall sf f sp bb bb' rs m rs' m' (S1' S2': state) s' t c, + body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> + bb' = remove_body bb -> + s' = (Machblock.State sf f sp (bb' :: c) rs' m') -> + match_states (Machblock.State sf f sp (bb::c) rs m) S1' -> + exists S2': state, step tge S1' t S2' /\ match_states s' S2' /\ t=E0. +Proof. +Admitted. + +(* Alternative form of step_simulation_bblock, easier to prove *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' rs m rs' m' t S1' s' c, + body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> + bb' = remove_body bb -> + exit_step return_address_offset ge (Machblock.exit bb') (Machblock.State sf f sp (bb' :: c) rs' m') t s' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states s' S2'. +Proof. + intros. + exploit step_simulation_body; eauto. intros. destruct H3 as (S2' & H31 & H32 & H33). + exploit step_simulation_control; eauto. intros. destruct H3 as (S3' & H41 & H42). + econstructor. econstructor. econstructor. + eapply H31. apply plus_star. eapply H41. + erewrite H33. traceEq. auto. +Qed. + +Lemma step_simulation_bblock: + forall sf f sp bb rs m rs' m' t S1' s' c, + body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) rs' m') t s' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states s' S2'. +Proof. + intros. eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. unfold remove_body; simpl. + inv H0. + - simpl in *. subst. econstructor. inv H2; try (econstructor; eauto; fail). + - simpl in *. subst. econstructor. +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; inv MS. + induction 1; intros. -- destruct TODO. +- (* bblock *) + left. eapply step_simulation_bblock; 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. @@ -1165,7 +1220,8 @@ Local Transparent destroyed_at_function_entry. assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } rewrite Heqrs''. Simpl. rewrite H4 by auto with asmgen. reflexivity. - - (* external function *) +- (* external function *) + inv MS. exploit functions_translated; eauto. intros [tf [A B]]. simpl in B. inv B. exploit extcall_arguments_match; eauto. @@ -1181,12 +1237,13 @@ Local Transparent destroyed_at_function_entry. apply agree_set_pair; auto. - (* return *) + inv MS. inv STACKS. simpl in *. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. Unshelve. - destruct TODO. + exact true. Qed. Lemma transf_initial_states: -- cgit From b466368baad51a1832da5d1f69b0e5bbc2c8a5b3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 2 Oct 2018 18:01:38 +0200 Subject: match_codestate et match_asmblock --- mppa_k1c/Asmblockgenproof.v | 175 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 142 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index cafc5dfc..e379d1f6 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -520,35 +520,6 @@ Qed. - Mach register values and Asm register values agree. *) -Inductive match_states: Machblock.state -> Asmblock.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) - (Asmblock.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) - (Asmblock.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) - (Asmblock.State rs m'). - (* Lemma exec_straight_steps: forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, @@ -1067,6 +1038,89 @@ Local Transparent destroyed_at_function_entry. Qed. *) +Inductive match_states: Machblock.state -> Asmblock.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) + (Asmblock.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) + (Asmblock.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) + (Asmblock.State rs m'). + +Inductive codestate: Type := + | Codestate: state -> list AB.bblock -> codestate. + +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m m' rs f tc ep c + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (TRANS: transl_blocks f c = OK tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_codestate fb (Machblock.State s fb sp c ms m) + (Codestate (Asmblock.State rs m') tc). + +Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := + | match_asmblock_intro: + forall rs f tf tc m ep c + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc), + match_asmblock fb (Codestate (Asmblock.State rs m) tc) (Asmblock.State rs m). + +Theorem match_codestate_state: + forall mbs abs cs s fb sp c ms m rs m' tc, + mbs = (Machblock.State s fb sp c ms m) -> + cs = (Codestate (Asmblock.State rs m') tc) -> + abs = (Asmblock.State rs m') -> + match_codestate fb mbs cs -> + match_asmblock fb cs abs -> + match_states mbs abs. +Proof. + intros until tc. intros H0 H1 H2 MCS MAB. subst. + inv MCS. inv MAB. rewrite FIND0 in FIND. inv FIND. + econstructor; eauto. inv AT. econstructor; eauto. +Qed. + +Theorem match_state_codestate: + forall mbs abs s fb sp c ms m rs m' tc tf ep f, + mbs = (Machblock.State s fb sp c ms m) -> + abs = (Asmblock.State rs m') -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_blocks f c = OK tc -> + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + match_states mbs abs -> + exists cs, (match_codestate fb mbs cs /\ match_asmblock fb cs abs + /\ cs = (Codestate (Asmblock.State rs m') tc)). +Proof. + intros. inv H4; try discriminate. + inv H6. inv H5. rewrite FIND in H1. inv H1. + esplit. repeat split. + econstructor; eauto. + econstructor; eauto. +Qed. + Definition measure (s: MB.state) : nat := match s with | MB.State _ _ _ _ _ _ => 0%nat @@ -1076,6 +1130,52 @@ Definition measure (s: MB.state) : nat := Axiom TODO: False. +Definition remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma remove_body_id : forall bb, MB.body bb = nil -> remove_body bb = bb. +Proof. + intros. destruct bb as [hd bdy ex]. simpl in *. subst. auto. +Qed. + +Lemma step_simulation_body: + forall sf f sp bb bb' ms m ms' m' rs0 m0 s' c tc tbb, + body_step ge sf f sp (MB.body bb) ms m ms' m' -> + bb' = remove_body bb -> + s' = (Machblock.State sf f sp (bb' :: c) ms' m') -> + match_codestate f (Machblock.State sf f sp (bb::c) ms m) (Codestate (State rs0 m0) tc) -> + exists S1'' rs1 m1, + S1'' = (Codestate (Asmblock.State rs1 m1) tc) + /\ exec_body tge (body tbb) rs0 m0 = Next rs1 m1 + /\ match_codestate f s' S1'' + /\ exists tbb' tc', tc = tbb' :: tc' +. +Proof. +Admitted. + +(* Alternative form of step_simulation_bblock, easier to prove *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' rs m rs' m' t s'' c S1, + body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> + bb' = remove_body bb -> + exit_step return_address_offset ge (Machblock.exit bb') (Machblock.State sf f sp (bb' :: c) rs' m') t s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 t S2 /\ match_states s'' S2. +Proof. + intros. inversion H2. subst. + remember (Machblock.State sf f sp (bb::c) rs m) as mbs. + remember (State rs0 m'0) as abs. + exploit match_state_codestate; eauto. inv AT. auto. + intros (S1' & MCS & MAS & cseq). subst. + exploit step_simulation_body; eauto. + intros (S1'' & EBD & S1''eq & MCS' & tbb' & tc' & tceq). + subst. + (* TODO - appliquer step_simulation_control *) +Admitted. + +(* TODO - step_simulation_control *) + +(* Previous attempt at simulation_control and simulation_body + Lemma step_simulation_control: forall (bb: Machblock.bblock) sf f sp bb c rs' m' t s' (S1' S2': state), exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb::c) rs' m') t s' -> @@ -1084,16 +1184,24 @@ Lemma step_simulation_control: Proof. Admitted. -Definition remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - Lemma step_simulation_body: - forall sf f sp bb bb' rs m rs' m' (S1' S2': state) s' t c, - body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> + forall body hd sf f sp bb bb' rs m rs' m' (S1' S2': state) s' t c, + body <> nil -> + bb = {| MB.header := hd; MB.body := body; MB.exit := None |} -> + body_step ge sf f sp body rs m rs' m' -> bb' = remove_body bb -> s' = (Machblock.State sf f sp (bb' :: c) rs' m') -> match_states (Machblock.State sf f sp (bb::c) rs m) S1' -> exists S2': state, step tge S1' t S2' /\ match_states s' S2' /\ t=E0. Proof. + induction body as [|bi body]. + - intros. contradict H; simpl; auto. + - intros. destruct body as [|bi' body]. + + clear IHbody H. + destruct TODO. (* proof of individual instructions *) + + inv H1. + exploit IHbody. eauto. discriminate. 2: eapply H12. eauto. eauto. + (* 2: eapply H4. *) Admitted. (* Alternative form of step_simulation_bblock, easier to prove *) @@ -1112,6 +1220,7 @@ Proof. eapply H31. apply plus_star. eapply H41. erewrite H33. traceEq. auto. Qed. +*) Lemma step_simulation_bblock: forall sf f sp bb rs m rs' m' t S1' s' c, -- cgit From 5486e861bf5cd3980258b95ecfaef0fdbdc9fdeb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Oct 2018 17:50:53 +0200 Subject: Schéma de simulation + les Pnop sont maintenant implicites MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 30 +++++++++---- mppa_k1c/Asmblockgen.v | 8 ++-- mppa_k1c/Asmblockgenproof.v | 103 +++++++++++++++++++++++++++++++++++++------- 3 files changed, 115 insertions(+), 26 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 51010c43..d517e280 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -389,8 +389,8 @@ Definition non_empty_bblock (body: list basic) (exit: option control): Prop (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. *) -Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := - non_empty_bblock body exit (* /\ builtin_alone body exit *). +(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := + non_empty_bblock body exit (* /\ builtin_alone body exit *). *) (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -399,7 +399,7 @@ Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; - correct: wf_bblock header body exit +(* correct: wf_bblock header body exit *) }. Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). @@ -416,7 +416,11 @@ Definition length_opt {A} (o: option A) : nat := We ignore labels here... The result is in Z to be compatible with operations on PC *) -Definition size (b:bblock): Z := Z.of_nat ((length (body b))+(length_opt (exit b))). +Definition size (b:bblock): Z := + match Z.of_nat ((length (body b))+(length_opt (exit b))) with + | 0 => 1 + | z => z + end. Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. Proof. @@ -434,12 +438,21 @@ Qed. Lemma size_positive (b:bblock): size b > 0. Proof. - unfold size. apply to_nat_pos. rewrite Nat2Z.id. - destruct b as [h b e COR]. simpl. inversion COR. (* inversion H. *) + unfold size. apply to_nat_pos. destruct (Z.of_nat _) eqn:eq. + - simpl. unfold Pos.to_nat. simpl. omega. + - rewrite <- eq. rewrite Nat2Z.id. destruct b as [h b e]. simpl in *. + destruct b. destruct e. simpl. omega. + simpl in eq. discriminate. + simpl. omega. + - rewrite <- eq. rewrite Nat2Z.id. destruct b as [h b e]. simpl in *. + destruct b. destruct e. simpl. omega. + simpl in eq. discriminate. + simpl. omega. +(* rewrite eq. (* inversion COR. *) (* inversion H. *) - assert ((length b > 0)%nat). apply length_nonil. auto. omega. - destruct e; simpl; try omega. contradict H; simpl; auto. -Qed. + *)Qed. Definition bblocks := list bblock. @@ -499,9 +512,10 @@ Program Definition bblock_basic_ctl (c: list basic) (i: option control) := | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} end end. -Next Obligation. +(* Next Obligation. constructor. subst; discriminate. Qed. + *) (** * Operational semantics *) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index cc3038ca..be930758 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -840,17 +840,19 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ Local Obligation Tactic := bblock_auto_correct. -Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := +(* 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) *) Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := match (extract_ctl ctl) with - | None => gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil - | Some (PExpand (Pbuiltin ef args res)) => (gen_bblock_noctl hd c) :: + | None => {| header := hd; body := c; exit := None |} :: nil +(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) + | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := c; exit := None |}) :: ((PExpand (Pbuiltin ef args res)) ::b nil) | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil end diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e379d1f6..61139df2 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1080,27 +1080,45 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (AG: agree ms sp rs) (DXP: ep = true -> rs#FP = parent_sp s), match_codestate fb (Machblock.State s fb sp c ms m) - (Codestate (Asmblock.State rs m') tc). + (Codestate (Asmblock.State rs m') tc) + | match_codestate_call: + forall s ms m m' rs tc + (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_codestate fb (Machblock.Callstate s fb ms m) + (Codestate (Asmblock.State rs m') tc) + | match_codestate_return: + forall s ms m m' rs tc + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_codestate fb (Machblock.Returnstate s ms m) + (Codestate (Asmblock.State rs m') tc). Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := | match_asmblock_intro: forall rs f tf tc m ep c (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc), - match_asmblock fb (Codestate (Asmblock.State rs m) tc) (Asmblock.State rs m). + match_asmblock fb (Codestate (Asmblock.State rs m) tc) (Asmblock.State rs m) +. Theorem match_codestate_state: - forall mbs abs cs s fb sp c ms m rs m' tc, - mbs = (Machblock.State s fb sp c ms m) -> - cs = (Codestate (Asmblock.State rs m') tc) -> - abs = (Asmblock.State rs m') -> + forall mbs abs fb cs, match_codestate fb mbs cs -> match_asmblock fb cs abs -> match_states mbs abs. Proof. - intros until tc. intros H0 H1 H2 MCS MAB. subst. - inv MCS. inv MAB. rewrite FIND0 in FIND. inv FIND. - econstructor; eauto. inv AT. econstructor; eauto. + intros until cs. intros MCS MAB. + inv MCS. + - inv MAB. rewrite FIND0 in FIND. inv FIND. + econstructor; eauto. inv AT. econstructor; eauto. + - inv MAB. econstructor; eauto. + - inv MAB. econstructor; eauto. Qed. Theorem match_state_codestate: @@ -1137,7 +1155,12 @@ Proof. intros. destruct bb as [hd bdy ex]. simpl in *. subst. auto. Qed. -Lemma step_simulation_body: +(* To be expanded later based on what we need for step_simu_control *) +Inductive control_preserved : state -> state -> Prop := + | control_pres_intro: + forall rs rs' m m', rs PC = rs' PC -> control_preserved (State rs m) (State rs' m'). + +Lemma step_simu_body: forall sf f sp bb bb' ms m ms' m' rs0 m0 s' c tc tbb, body_step ge sf f sp (MB.body bb) ms m ms' m' -> bb' = remove_body bb -> @@ -1148,10 +1171,55 @@ Lemma step_simulation_body: /\ exec_body tge (body tbb) rs0 m0 = Next rs1 m1 /\ match_codestate f s' S1'' /\ exists tbb' tc', tc = tbb' :: tc' + /\ control_preserved (State rs0 m0) (State rs1 m1) . Proof. Admitted. +Lemma transl_blocks_distrib: + forall f bb c tbb tc ef args res, + transl_blocks f (bb::c) = OK (tbb::tc) + -> MB.exit bb <> Some (MBbuiltin ef args res) + -> transl_block f bb = OK (tbb :: nil) + /\ transl_blocks f c = OK tc. +Proof. +Admitted. + +(** TODO - Voir comment gérer le PC *) +Lemma step_simu_control: + forall S0 bb bb' f tf f0 sf sp c ms' m' rs1 m1 tbb' tbb tc tc' rs0 m'0 t s'' ep ms + (AT: transl_code_at_pc ge (rs0 PC) f f0 (bb::c) ep tf (tbb :: tc')) + (DXP: ep = true -> rs0 GPR10 = parent_sp sf) + (AG : agree ms sp rs0), + bb' = remove_body bb -> + S0 = (State rs0 m'0) -> + match_codestate f (Machblock.State sf f sp (bb' :: c) ms' m') + (Codestate (State rs1 m1) (tbb' :: tc)) -> + match_asmblock f (Codestate S0 (tbb::tc)) (State rs0 m'0) -> + control_preserved S0 (State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') + (Machblock.State sf f sp (bb'::c) ms' m') t s'' -> + exists rs2 m2, + exec_bblock tge tf tbb rs1 m1 = Next rs2 m2 + /\ match_codestate f s'' (Codestate (State rs2 m2) tc) + /\ match_asmblock f (Codestate (State rs2 m2) tc) (State rs2 m2) + /\ plus step tge S0 t (State rs2 m2). +Proof. +Admitted. +(* intros until ms. intros AT DXP AG. intros H20 H21. intros MCS MAB CP ESTEP. + inv ESTEP. + - destruct TODO. + - inv MCS. exploit transl_blocks_distrib; eauto. rewrite <- H0; discriminate. intros (TRANSB & TRANSC). + clear TRANS. + monadInv TRANSB. simpl in EQ. inv EQ. simpl MB.exit in *. rewrite <- H0 in EQ1. inv EQ1. + inv H1. simpl in *. + inv CP. rewrite H1 in AT. inv AT. rewrite H2 in FIND. inv FIND. + repeat esplit; eauto. + + econstructor; eauto. inv AG0. unfold nextblock; unfold size; simpl. constructor; auto. intro; Simpl. + + unfold nextblock; simpl. unfold size; simpl. Simpl. rewrite <- H. simpl. econstructor; eauto. + +Admitted. + *) (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': forall sf f sp bb bb' rs m rs' m' t s'' c S1, @@ -1166,11 +1234,16 @@ Proof. remember (State rs0 m'0) as abs. exploit match_state_codestate; eauto. inv AT. auto. intros (S1' & MCS & MAS & cseq). subst. - exploit step_simulation_body; eauto. - intros (S1'' & EBD & S1''eq & MCS' & tbb' & tc' & tceq). - subst. - (* TODO - appliquer step_simulation_control *) -Admitted. + exploit step_simu_body; eauto. + intros (S1'' & rs1 & m1 & S1''eq & EBD & MCS' & tbb' & tc' & tceq & PRES). + subst. exploit step_simu_control; eauto. + intros (rs2 & m2 & EBB & MCS'' & MAB' & PSTEP). subst. + exists (State rs2 m2). split; auto. + eapply match_codestate_state; eauto. +Unshelve. + destruct TODO. +Qed. + (* TODO - step_simulation_control *) -- cgit From c3894c18635e272802edbaa75137f89feddcba0e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 4 Oct 2018 18:33:29 +0200 Subject: Fini le cas du step_simu_control où il n'y a pas de exit MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 23 ++++++--------- mppa_k1c/Asmblockgenproof.v | 70 ++++++++++++++++++++++++++++++++------------- 2 files changed, 59 insertions(+), 34 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index d517e280..d34578d5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -416,12 +416,13 @@ Definition length_opt {A} (o: option A) : nat := We ignore labels here... The result is in Z to be compatible with operations on PC *) -Definition size (b:bblock): Z := - match Z.of_nat ((length (body b))+(length_opt (exit b))) with - | 0 => 1 - | z => z +Definition size (b:bblock): Z := + match (body b, exit b) with + | (nil, None) => 1 + | _ => Z.of_nat (length (body b) + length_opt (exit b)) end. + Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. Proof. intros. destruct l; try (contradict H; auto; fail). @@ -438,16 +439,10 @@ Qed. Lemma size_positive (b:bblock): size b > 0. Proof. - unfold size. apply to_nat_pos. destruct (Z.of_nat _) eqn:eq. - - simpl. unfold Pos.to_nat. simpl. omega. - - rewrite <- eq. rewrite Nat2Z.id. destruct b as [h b e]. simpl in *. - destruct b. destruct e. simpl. omega. - simpl in eq. discriminate. - simpl. omega. - - rewrite <- eq. rewrite Nat2Z.id. destruct b as [h b e]. simpl in *. - destruct b. destruct e. simpl. omega. - simpl in eq. discriminate. - simpl. omega. + unfold size. destruct (body b). destruct (exit b). + - apply to_nat_pos. rewrite Nat2Z.id. simpl. omega. + - apply to_nat_pos. simpl. unfold Pos.to_nat. simpl. omega. + - apply to_nat_pos. rewrite Nat2Z.id. simpl. omega. (* rewrite eq. (* inversion COR. *) (* inversion H. *) - assert ((length b > 0)%nat). apply length_nonil. auto. omega. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 61139df2..04aabd5a 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1185,7 +1185,13 @@ Lemma transl_blocks_distrib: Proof. Admitted. -(** TODO - Voir comment gérer le PC *) +Lemma transl_basic_code_length : + forall f bdy tbdy, + transl_basic_code' f bdy true = OK tbdy -> length bdy = length tbdy. +Proof. +Admitted. + +(** TODO - factoriser la preuve du exit=None en introduisant des lemmes *) Lemma step_simu_control: forall S0 bb bb' f tf f0 sf sp c ms' m' rs1 m1 tbb' tbb tc tc' rs0 m'0 t s'' ep ms (AT: transl_code_at_pc ge (rs0 PC) f f0 (bb::c) ep tf (tbb :: tc')) @@ -1193,33 +1199,57 @@ Lemma step_simu_control: (AG : agree ms sp rs0), bb' = remove_body bb -> S0 = (State rs0 m'0) -> + exec_body tge (body tbb) rs0 m'0 = Next rs1 m1 -> match_codestate f (Machblock.State sf f sp (bb' :: c) ms' m') (Codestate (State rs1 m1) (tbb' :: tc)) -> - match_asmblock f (Codestate S0 (tbb::tc)) (State rs0 m'0) -> +(* match_asmblock f (Codestate S0 (tbb::tc)) (State rs0 m'0) -> *) control_preserved S0 (State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (Machblock.State sf f sp (bb'::c) ms' m') t s'' -> exists rs2 m2, - exec_bblock tge tf tbb rs1 m1 = Next rs2 m2 + exec_control tge tf (exit tbb') (nextblock tbb rs1) m1 = Next rs2 m2 /\ match_codestate f s'' (Codestate (State rs2 m2) tc) /\ match_asmblock f (Codestate (State rs2 m2) tc) (State rs2 m2) /\ plus step tge S0 t (State rs2 m2). Proof. -Admitted. -(* intros until ms. intros AT DXP AG. intros H20 H21. intros MCS MAB CP ESTEP. - inv ESTEP. + intros until ms. intros AT DXP AG. intros H20 H21. intros EBDY MCS (* MAB *) CP ESTEP. + (* destruct tbb as [thd tbdy tex]. destruct bb as [hd bdy ex]. destruct bb' as [hd' bdy' ex']. *) simpl in *. + inv CP. inv H0. + inv ESTEP. - destruct TODO. - - inv MCS. exploit transl_blocks_distrib; eauto. rewrite <- H0; discriminate. intros (TRANSB & TRANSC). - clear TRANS. - monadInv TRANSB. simpl in EQ. inv EQ. simpl MB.exit in *. rewrite <- H0 in EQ1. inv EQ1. - inv H1. simpl in *. - inv CP. rewrite H1 in AT. inv AT. rewrite H2 in FIND. inv FIND. - repeat esplit; eauto. - + econstructor; eauto. inv AG0. unfold nextblock; unfold size; simpl. constructor; auto. intro; Simpl. - + unfold nextblock; simpl. unfold size; simpl. Simpl. rewrite <- H. simpl. econstructor; eauto. - -Admitted. - *) + - inv MCS. destruct bb as [hd bdy ex]; simpl in *. subst. eapply transl_blocks_distrib in TRANS; [| simpl; discriminate]. + destruct TRANS as (TRANS1 & TRANS2). monadInv TRANS1. + inv EQ1. inv EQ. unfold gen_bblocks in H0; simpl in H0. inv H0. + esplit; esplit. esplit. 2: esplit. 3: esplit. + + simpl; auto. + + econstructor; eauto. inv AG0. econstructor; eauto. intro. Simpl. + + inv AT. econstructor; eauto. unfold nextblock; unfold size; simpl. + destruct tbb as [thd tbdy tex]; simpl. + eapply transl_blocks_distrib in H3. destruct H3 as (H31 & H32). monadInv H31. simpl in EQ. simpl in EQ1. + inv EQ1. inv H5. 2: simpl; discriminate. + simpl. rewrite FIND in H0. inv H0. rewrite H32 in TRANS2. inv TRANS2. + destruct bdy as [|i bdy]. + * inv EQ. Simpl. rewrite <- H1. rewrite <- H. econstructor; eauto. + assert (H42: size {| header := thd; body := nil; exit := None |} = 1) by (simpl; auto). + rewrite <- H42. eapply code_tail_next_int. + eapply transf_function_no_overflow; eauto. + eauto. + * apply transl_basic_code_length in EQ. destruct tbdy as [|i' tbdy]. simpl in EQ. discriminate. + Simpl. rewrite <- H1. rewrite <- H. econstructor; eauto. + assert (H42: size {| header := thd; body := i' ::i tbdy; exit := None |} = Z.of_nat (length (i' ::i tbdy))). + unfold size; simpl; auto. rewrite Nat.add_0_r. auto. + rewrite Nat.add_0_r. rewrite <- H42. eapply code_tail_next_int. + eapply transf_function_no_overflow; eauto. + eauto. + + apply plus_one. inv AT. econstructor; eauto. eapply functions_transl; eauto. + eapply find_bblock_tail; eauto. + unfold exec_bblock. rewrite EBDY. + eapply transl_blocks_distrib in H3; [|simpl; discriminate]. destruct H3 as [H31 H32]. + destruct tbb as [thd tbdy tex]; simpl in H31. monadInv H31. simpl. inv EQ1. inv EQ. inv H5. simpl. auto. +Unshelve. + all: destruct TODO. +Qed. + (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': forall sf f sp bb bb' rs m rs' m' t s'' c S1, @@ -1237,15 +1267,15 @@ Proof. exploit step_simu_body; eauto. intros (S1'' & rs1 & m1 & S1''eq & EBD & MCS' & tbb' & tc' & tceq & PRES). subst. exploit step_simu_control; eauto. +Admitted. (* TODO - fix the proof with the new step_simulation_control *) +(* eauto. intros (rs2 & m2 & EBB & MCS'' & MAB' & PSTEP). subst. exists (State rs2 m2). split; auto. eapply match_codestate_state; eauto. Unshelve. destruct TODO. Qed. - - -(* TODO - step_simulation_control *) + *) (* Previous attempt at simulation_control and simulation_body -- cgit From 556ca363a2a54699e313036b90ed1e11838e16f3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 8 Oct 2018 20:43:18 +0200 Subject: Un peu d'avancement dans exec_straight_control et cie --- mppa_k1c/Asmblock.v | 25 ++++---- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 137 +++++++++++++++++++++++++++++++++---------- mppa_k1c/Asmblockgenproof0.v | 81 +++++++++++++++++++++---- 4 files changed, 188 insertions(+), 59 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index d34578d5..6afa6e56 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -389,8 +389,8 @@ Definition non_empty_bblock (body: list basic) (exit: option control): Prop (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. *) -(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := - non_empty_bblock body exit (* /\ builtin_alone body exit *). *) +Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := + non_empty_bblock body exit (* /\ builtin_alone body exit *). (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -399,7 +399,7 @@ Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; -(* correct: wf_bblock header body exit *) + correct: wf_bblock header body exit }. Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). @@ -416,12 +416,12 @@ Definition length_opt {A} (o: option A) : nat := We ignore labels here... The result is in Z to be compatible with operations on PC *) -Definition size (b:bblock): Z := - match (body b, exit b) with +Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). +(* match (body b, exit b) with | (nil, None) => 1 - | _ => Z.of_nat (length (body b) + length_opt (exit b)) + | _ => end. - + *) Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. Proof. @@ -439,10 +439,9 @@ Qed. Lemma size_positive (b:bblock): size b > 0. Proof. - unfold size. destruct (body b). destruct (exit b). - - apply to_nat_pos. rewrite Nat2Z.id. simpl. omega. - - apply to_nat_pos. simpl. unfold Pos.to_nat. simpl. omega. - - apply to_nat_pos. rewrite Nat2Z.id. simpl. omega. + unfold size. destruct b as [hd bdy ex cor]. simpl. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). + inversion cor; contradict H; simpl; auto. (* rewrite eq. (* inversion COR. *) (* inversion H. *) - assert ((length b > 0)%nat). apply length_nonil. auto. omega. @@ -507,10 +506,10 @@ Program Definition bblock_basic_ctl (c: list basic) (i: option control) := | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} end end. -(* Next Obligation. +Next Obligation. constructor. subst; discriminate. Qed. - *) + (** * Operational semantics *) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index be930758..2e13d34b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -850,9 +850,9 @@ Local Obligation Tactic := bblock_auto_correct. (** 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 => {| header := hd; body := c; exit := None |} :: nil + | None => {| header := hd; body := Pnop::c; exit := None |} :: nil (* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) - | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := c; exit := None |}) :: + | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := Pnop::c; exit := None |}) :: ((PExpand (Pbuiltin ef args res)) ::b nil) | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil end diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 04aabd5a..f7263e4b 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1068,19 +1068,19 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (Asmblock.State rs m'). Inductive codestate: Type := - | Codestate: state -> list AB.bblock -> codestate. + | Codestate: state -> list AB.bblock -> option bblock -> codestate. Inductive match_codestate fb: Machblock.state -> codestate -> Prop := | match_codestate_intro: - forall s sp ms m m' rs f tc ep c + forall s sp ms m m' rs f tc ep c bb tbb (STACKS: match_stack ge s) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (MEXT: Mem.extends m m') - (TRANS: transl_blocks f c = OK tc) + (TRANS: transl_blocks f (bb::c) = OK (tbb::tc)) (AG: agree ms sp rs) (DXP: ep = true -> rs#FP = parent_sp s), - match_codestate fb (Machblock.State s fb sp c ms m) - (Codestate (Asmblock.State rs m') tc) + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb)) | match_codestate_call: forall s ms m m' rs tc (STACKS: match_stack ge s) @@ -1089,7 +1089,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), match_codestate fb (Machblock.Callstate s fb ms m) - (Codestate (Asmblock.State rs m') tc) + (Codestate (Asmblock.State rs m') tc None) | match_codestate_return: forall s ms m m' rs tc (STACKS: match_stack ge s) @@ -1097,14 +1097,14 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (AG: agree ms (parent_sp s) rs) (ATPC: rs PC = parent_ra s), match_codestate fb (Machblock.Returnstate s ms m) - (Codestate (Asmblock.State rs m') tc). + (Codestate (Asmblock.State rs m') tc None). Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := | match_asmblock_intro: - forall rs f tf tc m ep c + forall rs f tf tc m ep c bb tbb (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc), - match_asmblock fb (Codestate (Asmblock.State rs m) tc) (Asmblock.State rs m) + (AT: transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc)), + match_asmblock fb (Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb)) (Asmblock.State rs m) . Theorem match_codestate_state: @@ -1114,23 +1114,21 @@ Theorem match_codestate_state: match_states mbs abs. Proof. intros until cs. intros MCS MAB. - inv MCS. - - inv MAB. rewrite FIND0 in FIND. inv FIND. + inv MCS; inv MAB. + rewrite FIND0 in FIND. inv FIND. econstructor; eauto. inv AT. econstructor; eauto. - - inv MAB. econstructor; eauto. - - inv MAB. econstructor; eauto. Qed. Theorem match_state_codestate: - forall mbs abs s fb sp c ms m rs m' tc tf ep f, - mbs = (Machblock.State s fb sp c ms m) -> + forall mbs abs s fb sp bb c ms m rs m' tbb tc tf ep f, + mbs = (Machblock.State s fb sp (bb::c) ms m) -> abs = (Asmblock.State rs m') -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_blocks f c = OK tc -> - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + transl_blocks f (bb::c) = OK (tbb::tc) -> + transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> match_states mbs abs -> exists cs, (match_codestate fb mbs cs /\ match_asmblock fb cs abs - /\ cs = (Codestate (Asmblock.State rs m') tc)). + /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). Proof. intros. inv H4; try discriminate. inv H6. inv H5. rewrite FIND in H1. inv H1. @@ -1139,6 +1137,40 @@ Proof. econstructor; eauto. Qed. +Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := Pnop::nil; AB.exit := AB.exit bb |}. +Next Obligation. + unfold wf_bblock. unfold non_empty_bblock. left; discriminate. +Qed. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 (Pnop::nil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + + +Axiom TODO: False. + + +Theorem match_asmblock_step: + forall fb f fb' rs1 m1 rs2 m2 rs3 m3 rs4 m4 tbb tc S1, + Genv.find_funct_ptr tge fb = Some (Internal f) -> + match_asmblock fb (Codestate (Asmblock.State rs1 m1) (tbb::tc) (Some tbb)) S1 -> + (exists tbb', exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + /\ exec_straight tge (body tbb') rs2 m2 (body (remove_body tbb)) rs3 m3 + /\ exec_control_rel tge f (exit tbb) tbb rs3 m3 rs4 m4) -> + exists S4 tc' t, + match_asmblock fb' (Codestate (Asmblock.State rs4 m4) tc' None) S4 + /\ step tge S1 t S4. +Proof. + intros. destruct H1 as (tbb' & H1 & H2 & H3). + exploit exec_straight_trans. eapply H1. eapply H2. intro H4; clear H1; clear H2. + exploit exec_straight_bblock. eapply exec_straight_pnil. eapply H4. eapply H3. intro H5; clear H3; clear H4. + inv H5. destruct TODO. +Qed. + Definition measure (s: MB.state) : nat := match s with | MB.State _ _ _ _ _ _ => 0%nat @@ -1146,9 +1178,7 @@ Definition measure (s: MB.state) : nat := | MB.Returnstate _ _ _ => 1%nat end. -Axiom TODO: False. - -Definition remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. +(* Definition remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. Lemma remove_body_id : forall bb, MB.body bb = nil -> remove_body bb = bb. Proof. @@ -1208,15 +1238,58 @@ Lemma step_simu_control: (Machblock.State sf f sp (bb'::c) ms' m') t s'' -> exists rs2 m2, exec_control tge tf (exit tbb') (nextblock tbb rs1) m1 = Next rs2 m2 + /\ plus step tge S0 t (State rs2 m2) /\ match_codestate f s'' (Codestate (State rs2 m2) tc) /\ match_asmblock f (Codestate (State rs2 m2) tc) (State rs2 m2) - /\ plus step tge S0 t (State rs2 m2). +. Proof. intros until ms. intros AT DXP AG. intros H20 H21. intros EBDY MCS (* MAB *) CP ESTEP. (* destruct tbb as [thd tbdy tex]. destruct bb as [hd bdy ex]. destruct bb' as [hd' bdy' ex']. *) simpl in *. inv CP. inv H0. inv ESTEP. - - destruct TODO. + - inv MCS. destruct bb as [hd bdy ex]. simpl in H. subst. destruct ctl. + + (* MBcall *) + eapply transl_blocks_distrib in TRANS; [| simpl; discriminate]. + destruct TRANS as (TRANS1 & TRANS2). unfold remove_body in TRANS1; simpl in TRANS1. monadInv TRANS1. + inv EQ. simpl in EQ1. inv AT. assert (f0 = f1) by congruence. subst. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + unfold remove_body in H0; simpl in H0. inv H0. + assert (f0 = f1) by congruence. subst f0. + eapply transl_blocks_distrib in H5; [| simpl; discriminate]. destruct H5 as (H51 & H52). assert (tc=tc') by congruence. + subst tc'. + destruct s0 as [rf|fid]; simpl in H18. simpl in EQ1. inversion EQ1. monadInv EQ1. + esplit; esplit. esplit. + + inv H2. simpl; auto. + + (* Direct call ? *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr f (Ptrofs.add ofs (Ptrofs.repr (size tbb)))) f f1 c false tf tc). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + esplit. + + apply plus_one. eapply exec_step_internal. eauto. + eapply functions_transl; eauto. eapply find_bblock_tail; eauto. + simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H18. + unfold nextblock; unfold size; simpl. Simpl. unfold exec_bblock. rewrite EBDY. + monadInv H51. simpl in EQ1. inv EQ1. inversion H5. simpl. unfold nextblock; unfold size; simpl. + unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H18. auto. + + split. Simpl. econstructor. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + + + (* MBtailcall *) destruct TODO. + + (* MBbuiltin *) destruct TODO. + + (* MBgoto *) destruct TODO. + + (* MBcond *) destruct TODO. + + (* MBjumptable *) destruct TODO. + + (* MBreturn *) destruct TODO. - inv MCS. destruct bb as [hd bdy ex]; simpl in *. subst. eapply transl_blocks_distrib in TRANS; [| simpl; discriminate]. destruct TRANS as (TRANS1 & TRANS2). monadInv TRANS1. inv EQ1. inv EQ. unfold gen_bblocks in H0; simpl in H0. inv H0. @@ -1276,7 +1349,7 @@ Unshelve. destruct TODO. Qed. *) - + *) (* Previous attempt at simulation_control and simulation_body Lemma step_simulation_control: @@ -1325,11 +1398,11 @@ Proof. Qed. *) -Lemma step_simulation_bblock: - forall sf f sp bb rs m rs' m' t S1' s' c, - body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) rs' m') t s' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1' -> +(* Lemma step_simulation_bblock: + forall sf f sp bb ms m ms' m' t S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + exit_step return_address_offset ge (Machblock.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 s' S2'. Proof. intros. eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. unfold remove_body; simpl. @@ -1337,7 +1410,7 @@ Proof. - simpl in *. subst. econstructor. inv H2; try (econstructor; eauto; fail). - simpl in *. subst. econstructor. Qed. - + *) Theorem step_simulation: forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1347,7 +1420,7 @@ Proof. induction 1; intros. - (* bblock *) - left. eapply step_simulation_bblock; eauto. + left. (* eapply step_simulation_bblock; eauto. *) destruct TODO. - (* internal function *) inv MS. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 3b3ac165..81dd36b5 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -568,6 +568,35 @@ Inductive transl_code_at_pc (ge: MB.genv): code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + Section STRAIGHTLINE. Variable ge: genv. @@ -592,6 +621,46 @@ Inductive exec_straight: list basic -> regset -> mem -> exec_straight c rs2 m2 c' rs3 m3 -> exec_straight (i :: c) rs1 m1 c' rs3 m3. +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + exec_body ge c rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros. inv H. + - intros. inv H. + + simpl. rewrite H7. auto. + + apply IHc in H8. rewrite <- H8. simpl. rewrite H2. auto. +Qed. + +(* + contradict H4. generalize i1. induction c; simpl; try discriminate. + intros i0 X; inversion X. subst. eapply IHc. eauto. *) + +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_trans: forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, exec_straight c1 rs1 m1 c2 rs2 m2 -> @@ -668,18 +737,6 @@ Ltac Simplif := Ltac Simpl := repeat Simplif. -Lemma exec_straight_body: - forall c rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - exec_body ge c rs1 m1 = Next rs2 m2. -Proof. - induction c. - - intros. inv H. - - intros. inv H. - + inv H7. simpl. remember (exec_basic_instr _ _ _ _) as ebi. destruct ebi; simpl; auto. - + simpl. rewrite H2. apply IHc. auto. -Qed. - Lemma exec_basic_instr_pc: forall b rs1 m1 rs2 m2, exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> -- cgit From 5ef35384172fe6d3b09148959314fdc13436445b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 9 Oct 2018 18:32:45 +0200 Subject: Beaucoup de quincaillerie avec les transl_blocks, travail en cours --- mppa_k1c/Asmblockgenproof.v | 139 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 116 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index f7263e4b..41ae6f94 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -22,6 +22,8 @@ Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. Module MB := Machblock. Module AB := Asmblock. +Definition rao := return_address_offset. + Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -1100,9 +1102,8 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (Codestate (Asmblock.State rs m') tc None). Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := - | match_asmblock_intro: + | match_asmblock_some: forall rs f tf tc m ep c bb tbb - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (AT: transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc)), match_asmblock fb (Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb)) (Asmblock.State rs m) . @@ -1114,9 +1115,10 @@ Theorem match_codestate_state: match_states mbs abs. Proof. intros until cs. intros MCS MAB. - inv MCS; inv MAB. - rewrite FIND0 in FIND. inv FIND. - econstructor; eauto. inv AT. econstructor; eauto. + inv MCS; inv MAB. + - inv AT. rewrite H0 in FIND. inv FIND. +(* rewrite FIND0 in FIND. inv FIND. *) + econstructor; eauto. rewrite <- H. (* inv AT. *) econstructor; eauto. Qed. Theorem match_state_codestate: @@ -1150,26 +1152,126 @@ Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. Qed. - Axiom TODO: False. +Lemma transl_blocks_distrib: + forall c f bb tbb tc, + transl_blocks f (bb::c) = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb = OK (tbb :: nil) + /\ transl_blocks f c = OK tc. +Proof. + intros. destruct bb as [hd bdy ex]. simpl in *. + monadInv H. monadInv EQ. simpl in *. + destruct ex. + - destruct c0. + + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + destruct TODO. (* TODO - requires Sylvain black magic *) + + simpl in EQ. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + simpl in EQ. unfold transl_cbranch in EQ. destruct c0; destruct c. + all: try ( + repeat (destruct l; try discriminate); + monadInv EQ; simpl in *; inv H1; + unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; rewrite EQ; simpl; + unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( + simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; + rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( + simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; + rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. + rewrite EQ2; simpl. unfold gen_bblocks; simpl. unfold transl_opt_compuimm in *. + destruct (select_comp n c0). destruct c; try (simpl; inv H1; auto). + unfold transl_comp in *. simpl. inv H1. auto. + * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl. rewrite EQ0; simpl. + rewrite EQ2; simpl. unfold gen_bblocks in *. simpl in *. unfold transl_opt_compuimm in *. + destruct (select_comp n c0). destruct c1; try (simpl; inv H1; auto). simpl in *. inv H1. auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; + unfold transl_opt_compluimm in *; + destruct (select_compl n c0) eqn:SEL; try (destruct c; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + monadInv EQ. rewrite EQ2; simpl. unfold gen_bblocks in *; simpl in *. + unfold transl_opt_compluimm in *. destruct (select_compl n c0); try (destruct c1; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). + + simpl in EQ. discriminate. + + simpl in EQ. inv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. unfold gen_bblocks in *. + simpl in *. inv H1; auto. + - monadInv EQ. simpl in H1. inv H1. unfold transl_block. simpl. rewrite EQ0. simpl. + unfold gen_bblocks. simpl. auto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb tbb, + transl_block f bb = OK (tbb :: nil) -> + exists c c', + transl_basic_code' f (MB.body bb) true = OK c + /\ transl_instr_control f (MB.exit bb) true = OK c' + /\ body tbb = c ++ (extract_basic c') + /\ exit tbb = extract_ctl c'. +Proof. + intros. monadInv H. + repeat eexists. eauto. eauto. +(* TODO - besoin de lemmes supplémentaires sur gen_bblocks + Toute la quincaillerie du lemme au dessus doit aller dans un lemme intermédiaire *) + unfold gen_bblocks in H0. +Admitted. -Theorem match_asmblock_step: +Theorem step_simu_control: + forall bb fb fn s sp c ms' m' rs2 m2 tbb tc t S'', + MB.body bb = nil -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + match_codestate fb (MB.State s fb sp (bb::c) ms' m') + (Codestate (Asmblock.State rs2 m2) (tbb::tc) (Some tbb)) -> + exit_step rao ge (MB.exit bb) (MB.State s fb sp (bb::c) ms' m') t S'' -> + (exists rs3 m3 rs4 m4, + exec_straight tge (body tbb) rs2 m2 nil rs3 m3 + /\ exec_control tge fn (exit tbb) rs3 m3 = Next rs4 m4). +Proof. + intros until S''. intros H FIND MCS ESTEP. inv ESTEP. + - destruct TODO. + - inv MCS. clear H12. + exploit transl_blocks_distrib; eauto. rewrite <- H1. discriminate. + intros (TLB & TLBS). destruct bb as [hd bdy ex]; simpl in *. subst. + monadInv TRANS. monadInv EQ. simpl in *. inv EQ. inv EQ0. inv H0. simpl in *. + repeat eexists. econstructor; eauto. econstructor; eauto. +Qed. + + +(* Theorem match_asmblock_step: forall fb f fb' rs1 m1 rs2 m2 rs3 m3 rs4 m4 tbb tc S1, Genv.find_funct_ptr tge fb = Some (Internal f) -> match_asmblock fb (Codestate (Asmblock.State rs1 m1) (tbb::tc) (Some tbb)) S1 -> - (exists tbb', exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 - /\ exec_straight tge (body tbb') rs2 m2 (body (remove_body tbb)) rs3 m3 - /\ exec_control_rel tge f (exit tbb) tbb rs3 m3 rs4 m4) -> + (exists tbb' tc'', + exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + /\ exec_straight tge (body tbb') rs2 m2 (body (remove_body tbb)) rs3 m3 + /\ exec_control_rel tge f (exit tbb) tbb rs3 m3 rs4 m4) -> exists S4 tc' t, - match_asmblock fb' (Codestate (Asmblock.State rs4 m4) tc' None) S4 - /\ step tge S1 t S4. + step tge S1 t S4 + /\ match_asmblock fb' (Codestate (Asmblock.State rs4 m4) tc' None) S4 +. Proof. intros. destruct H1 as (tbb' & H1 & H2 & H3). exploit exec_straight_trans. eapply H1. eapply H2. intro H4; clear H1; clear H2. exploit exec_straight_bblock. eapply exec_straight_pnil. eapply H4. eapply H3. intro H5; clear H3; clear H4. - inv H5. destruct TODO. -Qed. + inv H5. inv H0. clear H7. inv AT. + repeat eexists. econstructor; eauto. + exploit functions_translated. eapply H2. intro. destruct H6 as (tf2 & FIND6 & TRANS6). + rewrite FIND6 in H. inv H. inv TRANS6. monadInv H6. rewrite EQ in H3. inv H3. + eapply find_bblock_tail. eapply H5. + econstructor. +Qed. *) Definition measure (s: MB.state) : nat := match s with @@ -1206,15 +1308,6 @@ Lemma step_simu_body: Proof. Admitted. -Lemma transl_blocks_distrib: - forall f bb c tbb tc ef args res, - transl_blocks f (bb::c) = OK (tbb::tc) - -> MB.exit bb <> Some (MBbuiltin ef args res) - -> transl_block f bb = OK (tbb :: nil) - /\ transl_blocks f c = OK tc. -Proof. -Admitted. - Lemma transl_basic_code_length : forall f bdy tbdy, transl_basic_code' f bdy true = OK tbdy -> length bdy = length tbdy. -- cgit From 83119fc0b190707cf5025ae2f44ac13dec68b692 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 10 Oct 2018 15:39:41 +0200 Subject: Preuve de MBcall et du exit=None dans le step_simu_control --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 144 ++++++++++++++++++++++++++++++++++---------- 2 files changed, 115 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 2e13d34b..28941e22 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -850,11 +850,11 @@ Local Obligation Tactic := bblock_auto_correct. (** 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 => {| header := hd; body := Pnop::c; exit := None |} :: nil + | None => {| header := hd; body := Pnop::(c ++ (extract_basic ctl)); exit := None |} :: nil (* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := Pnop::c; exit := None |}) :: ((PExpand (Pbuiltin ef args res)) ::b nil) - | Some (PCtlFlow i) => {| header := hd; body := c ++ (extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil + | Some (PCtlFlow i) => {| header := hd; body := Pnop :: (c ++ (extract_basic ctl)); exit := Some (PCtlFlow i) |} :: nil end . diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 41ae6f94..6add1b98 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -22,8 +22,6 @@ Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. Module MB := Machblock. Module AB := Asmblock. -Definition rao := return_address_offset. - Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -1074,7 +1072,7 @@ Inductive codestate: Type := Inductive match_codestate fb: Machblock.state -> codestate -> Prop := | match_codestate_intro: - forall s sp ms m m' rs f tc ep c bb tbb + forall s sp ms m m' rs f tc ep c bb tbb tbb' (STACKS: match_stack ge s) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (MEXT: Mem.extends m m') @@ -1082,7 +1080,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (AG: agree ms sp rs) (DXP: ep = true -> rs#FP = parent_sp s), match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb)) + (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) | match_codestate_call: forall s ms m m' rs tc (STACKS: match_stack ge s) @@ -1103,22 +1101,28 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := | match_asmblock_some: - forall rs f tf tc m ep c bb tbb - (AT: transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc)), - match_asmblock fb (Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb)) (Asmblock.State rs m) + forall rs f tf tc m tbb tbb' ofs + (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_asmblock fb (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) (Asmblock.State rs m) . Theorem match_codestate_state: - forall mbs abs fb cs, + forall mbs abs fb cs rs m tbb tc, + cs = Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb) -> match_codestate fb mbs cs -> match_asmblock fb cs abs -> match_states mbs abs. Proof. - intros until cs. intros MCS MAB. - inv MCS; inv MAB. - - inv AT. rewrite H0 in FIND. inv FIND. + intros until tc. intros ? MCS MAB. + inv MCS; inv MAB. inv H1. + - rewrite FIND0 in FIND. inv FIND. (* rewrite FIND0 in FIND. inv FIND. *) - econstructor; eauto. rewrite <- H. (* inv AT. *) econstructor; eauto. + econstructor; eauto. rewrite PCeq. (* inv AT. *) econstructor; eauto. + - discriminate. + - discriminate. Qed. Theorem match_state_codestate: @@ -1135,8 +1139,10 @@ Proof. intros. inv H4; try discriminate. inv H6. inv H5. rewrite FIND in H1. inv H1. esplit. repeat split. + econstructor. 4: eapply H2. all: eauto. (* inv H3. eapply H1. *) + inv AT. econstructor; eauto. - econstructor; eauto. + congruence. Qed. Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := Pnop::nil; AB.exit := AB.exit bb |}. @@ -1212,40 +1218,116 @@ Proof. unfold gen_bblocks. simpl. auto. Qed. +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = Pnop :: (tbdy ++ (extract_basic tex)) + /\ exit tbb = extract_ctl tex. +Proof. + intros. unfold gen_bblocks in H. + destruct (extract_ctl tex). + - destruct c. + + destruct i. inv H. + + inv H. auto. + - inv H. auto. +Qed. + Lemma transl_block_nobuiltin: forall f bb tbb, transl_block f bb = OK (tbb :: nil) -> exists c c', transl_basic_code' f (MB.body bb) true = OK c /\ transl_instr_control f (MB.exit bb) true = OK c' - /\ body tbb = c ++ (extract_basic c') + /\ body tbb = Pnop :: (c ++ (extract_basic c')) /\ exit tbb = extract_ctl c'. Proof. intros. monadInv H. - repeat eexists. eauto. eauto. -(* TODO - besoin de lemmes supplémentaires sur gen_bblocks - Toute la quincaillerie du lemme au dessus doit aller dans un lemme intermédiaire *) - unfold gen_bblocks in H0. -Admitted. + eexists. eexists. split; eauto. split; eauto. + eapply gen_bblocks_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. Theorem step_simu_control: - forall bb fb fn s sp c ms' m' rs2 m2 tbb tc t S'', + forall bb fb fn s sp c ms' m' rs2 m2 tbb tc t S'' rs1 m1 cs2, MB.body bb = nil -> Genv.find_funct_ptr tge fb = Some (Internal fn) -> - match_codestate fb (MB.State s fb sp (bb::c) ms' m') - (Codestate (Asmblock.State rs2 m2) (tbb::tc) (Some tbb)) -> - exit_step rao ge (MB.exit bb) (MB.State s fb sp (bb::c) ms' m') t S'' -> + cs2 = Codestate (Asmblock.State rs2 m2) (tbb::tc) (Some tbb) -> + match_codestate fb (MB.State s fb sp (bb::c) ms' m') cs2 -> + match_asmblock fb cs2 (Asmblock.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_straight tge (body tbb) rs2 m2 nil rs3 m3 - /\ exec_control tge fn (exit tbb) rs3 m3 = Next rs4 m4). + /\ exec_control_rel tge fn (exit tbb) tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). Proof. - intros until S''. intros H FIND MCS ESTEP. inv ESTEP. - - destruct TODO. - - inv MCS. clear H12. - exploit transl_blocks_distrib; eauto. rewrite <- H1. discriminate. - intros (TLB & TLBS). destruct bb as [hd bdy ex]; simpl in *. subst. - monadInv TRANS. monadInv EQ. simpl in *. inv EQ. inv EQ0. inv H0. simpl in *. - repeat eexists. econstructor; eauto. econstructor; eauto. + intros until cs2. intros ? FIND ? MCS MAS ESTEP. inv ESTEP. + - inv MCS. inv MAS. + destruct ctl. + + (* MBcall *) + exploit transl_blocks_distrib; eauto. rewrite <- H1. discriminate. + intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. + intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. + destruct tbb as [hd bdy ex]; simpl in *. subst. + destruct bb as [mhd mbdy mex]; simpl in *. subst. + inv TBC. inv TIC. inv H2. + + 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 H12. + * (* Indirect call *) inv H0. + * (* Direct call *) + monadInv H0. + 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. econstructor; eauto. econstructor; eauto. + remember (nextblock _ _) as rs'1. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + exploit nextblock_preserves. eapply Heqrs'1. eauto. auto. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H12. eauto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct TODO. + + (* MBbuiltin *) + destruct TODO. + + (* MBgoto *) + destruct TODO. + + (* MBcond *) + destruct TODO. + + (* MBjumptable *) + destruct TODO. + + (* MBreturn *) + destruct TODO. + - inv MCS. inv MAS. + exploit transl_blocks_distrib; eauto. rewrite <- H2. discriminate. + intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. + intros (c0 & c' & TBB & TCT & BEQ & EXEQ). + destruct bb as [hd bdy ex]; simpl in *. subst. inv TBB. inv TCT. simpl in *. + repeat eexists. rewrite BEQ. econstructor; eauto. econstructor; eauto. + rewrite EXEQ. econstructor; eauto. econstructor; eauto. + unfold nextblock. 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. Qed. -- cgit From 2adcf74ddf10ec2cf577238c73f3389469e72d41 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 10 Oct 2018 17:35:40 +0200 Subject: Avancement du schéma. A voir problème des traces MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgenproof.v | 314 ++++++++++--------------------------------- mppa_k1c/Asmblockgenproof0.v | 18 ++- 2 files changed, 86 insertions(+), 246 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 6add1b98..7f54b874 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1150,6 +1150,9 @@ Next Obligation. unfold wf_bblock. unfold non_empty_bblock. left; discriminate. 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::nil) rs2 m2 -> @@ -1259,16 +1262,16 @@ Proof. Qed. Theorem step_simu_control: - forall bb fb fn s sp c ms' m' rs2 m2 tbb tc t S'' rs1 m1 cs2, - MB.body bb = nil -> + forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 cs2, + MB.body bb' = nil -> Genv.find_funct_ptr tge fb = Some (Internal fn) -> - cs2 = Codestate (Asmblock.State rs2 m2) (tbb::tc) (Some tbb) -> - match_codestate fb (MB.State s fb sp (bb::c) ms' m') cs2 -> + cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmblock fb cs2 (Asmblock.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb) (MB.State s fb sp (bb::c) ms' m') t S'' -> + 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_straight tge (body tbb) rs2 m2 nil rs3 m3 - /\ exec_control_rel tge fn (exit tbb) tbb rs3 m3 rs4 m4 + exec_straight tge (body tbb') rs2 m2 nil rs3 m3 + /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 /\ match_states S'' (State rs4 m4)). Proof. intros until cs2. intros ? FIND ? MCS MAS ESTEP. inv ESTEP. @@ -1278,8 +1281,8 @@ Proof. exploit transl_blocks_distrib; eauto. rewrite <- H1. discriminate. intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. - destruct tbb as [hd bdy ex]; simpl in *. subst. - destruct bb as [mhd mbdy mex]; simpl in *. subst. + destruct tbb' as [hd' bdy' ex']; simpl in *. subst. + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H2. assert (f0 = f) by congruence. subst f0. @@ -1319,7 +1322,7 @@ Proof. exploit transl_blocks_distrib; eauto. rewrite <- H2. discriminate. intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. intros (c0 & c' & TBB & TCT & BEQ & EXEQ). - destruct bb as [hd bdy ex]; simpl in *. subst. inv TBB. inv TCT. simpl in *. + destruct bb' as [hd' bdy' ex']; simpl in *. subst. inv TBB. inv TCT. simpl in *. repeat eexists. rewrite BEQ. econstructor; eauto. econstructor; eauto. rewrite EXEQ. econstructor; eauto. econstructor; eauto. unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. @@ -1330,262 +1333,86 @@ Proof. eapply agree_exten; eauto. intros. Simpl. Qed. - -(* Theorem match_asmblock_step: - forall fb f fb' rs1 m1 rs2 m2 rs3 m3 rs4 m4 tbb tc S1, - Genv.find_funct_ptr tge fb = Some (Internal f) -> - match_asmblock fb (Codestate (Asmblock.State rs1 m1) (tbb::tc) (Some tbb)) S1 -> - (exists tbb' tc'', - exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 - /\ exec_straight tge (body tbb') rs2 m2 (body (remove_body tbb)) rs3 m3 - /\ exec_control_rel tge f (exit tbb) tbb rs3 m3 rs4 m4) -> - exists S4 tc' t, - step tge S1 t S4 - /\ match_asmblock fb' (Codestate (Asmblock.State rs4 m4) tc' None) S4 -. -Proof. - intros. destruct H1 as (tbb' & H1 & H2 & H3). - exploit exec_straight_trans. eapply H1. eapply H2. intro H4; clear H1; clear H2. - exploit exec_straight_bblock. eapply exec_straight_pnil. eapply H4. eapply H3. intro H5; clear H3; clear H4. - inv H5. inv H0. clear H7. inv AT. - repeat eexists. econstructor; eauto. - exploit functions_translated. eapply H2. intro. destruct H6 as (tf2 & FIND6 & TRANS6). - rewrite FIND6 in H. inv H. inv TRANS6. monadInv H6. rewrite EQ in H3. inv H3. - eapply find_bblock_tail. eapply H5. - 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 remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma remove_body_id : forall bb, MB.body bb = nil -> remove_body bb = bb. -Proof. - intros. destruct bb as [hd bdy ex]. simpl in *. subst. auto. -Qed. - -(* To be expanded later based on what we need for step_simu_control *) -Inductive control_preserved : state -> state -> Prop := - | control_pres_intro: - forall rs rs' m m', rs PC = rs' PC -> control_preserved (State rs m) (State rs' m'). - -Lemma step_simu_body: - forall sf f sp bb bb' ms m ms' m' rs0 m0 s' c tc tbb, - body_step ge sf f sp (MB.body bb) ms m ms' m' -> - bb' = remove_body bb -> - s' = (Machblock.State sf f sp (bb' :: c) ms' m') -> - match_codestate f (Machblock.State sf f sp (bb::c) ms m) (Codestate (State rs0 m0) tc) -> - exists S1'' rs1 m1, - S1'' = (Codestate (Asmblock.State rs1 m1) tc) - /\ exec_body tge (body tbb) rs0 m0 = Next rs1 m1 - /\ match_codestate f s' S1'' - /\ exists tbb' tc', tc = tbb' :: tc' - /\ control_preserved (State rs0 m0) (State rs1 m1) -. -Proof. -Admitted. - -Lemma transl_basic_code_length : - forall f bdy tbdy, - transl_basic_code' f bdy true = OK tbdy -> length bdy = length tbdy. +Theorem step_simu_body: + forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', + match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + exists rs2 m2 tbb', + exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') + (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) + /\ exit tbb' = exit tbb. Proof. + Admitted. -(** TODO - factoriser la preuve du exit=None en introduisant des lemmes *) -Lemma step_simu_control: - forall S0 bb bb' f tf f0 sf sp c ms' m' rs1 m1 tbb' tbb tc tc' rs0 m'0 t s'' ep ms - (AT: transl_code_at_pc ge (rs0 PC) f f0 (bb::c) ep tf (tbb :: tc')) - (DXP: ep = true -> rs0 GPR10 = parent_sp sf) - (AG : agree ms sp rs0), - bb' = remove_body bb -> - S0 = (State rs0 m'0) -> - exec_body tge (body tbb) rs0 m'0 = Next rs1 m1 -> - match_codestate f (Machblock.State sf f sp (bb' :: c) ms' m') - (Codestate (State rs1 m1) (tbb' :: tc)) -> -(* match_asmblock f (Codestate S0 (tbb::tc)) (State rs0 m'0) -> *) - control_preserved S0 (State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') - (Machblock.State sf f sp (bb'::c) ms' m') t s'' -> - exists rs2 m2, - exec_control tge tf (exit tbb') (nextblock tbb rs1) m1 = Next rs2 m2 - /\ plus step tge S0 t (State rs2 m2) - /\ match_codestate f s'' (Codestate (State rs2 m2) tc) - /\ match_asmblock f (Codestate (State rs2 m2) tc) (State rs2 m2) -. +Lemma transl_blocks_nonil: + forall f bb c tc, + transl_blocks f (bb::c) = OK tc -> + exists tbb tc', tc = tbb :: tc'. Proof. - intros until ms. intros AT DXP AG. intros H20 H21. intros EBDY MCS (* MAB *) CP ESTEP. - (* destruct tbb as [thd tbdy tex]. destruct bb as [hd bdy ex]. destruct bb' as [hd' bdy' ex']. *) simpl in *. - inv CP. inv H0. - inv ESTEP. - - inv MCS. destruct bb as [hd bdy ex]. simpl in H. subst. destruct ctl. - + (* MBcall *) - eapply transl_blocks_distrib in TRANS; [| simpl; discriminate]. - destruct TRANS as (TRANS1 & TRANS2). unfold remove_body in TRANS1; simpl in TRANS1. monadInv TRANS1. - inv EQ. simpl in EQ1. inv AT. assert (f0 = f1) by congruence. subst. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - unfold remove_body in H0; simpl in H0. inv H0. - assert (f0 = f1) by congruence. subst f0. - eapply transl_blocks_distrib in H5; [| simpl; discriminate]. destruct H5 as (H51 & H52). assert (tc=tc') by congruence. - subst tc'. - destruct s0 as [rf|fid]; simpl in H18. simpl in EQ1. inversion EQ1. monadInv EQ1. - esplit; esplit. esplit. - - inv H2. simpl; auto. - - (* Direct call ? *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr f (Ptrofs.add ofs (Ptrofs.repr (size tbb)))) f f1 c false tf tc). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - esplit. - - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_bblock_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H18. - unfold nextblock; unfold size; simpl. Simpl. unfold exec_bblock. rewrite EBDY. - monadInv H51. simpl in EQ1. inv EQ1. inversion H5. simpl. unfold nextblock; unfold size; simpl. - unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H18. auto. - - split. Simpl. econstructor. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - - + (* MBtailcall *) destruct TODO. - + (* MBbuiltin *) destruct TODO. - + (* MBgoto *) destruct TODO. - + (* MBcond *) destruct TODO. - + (* MBjumptable *) destruct TODO. - + (* MBreturn *) destruct TODO. - - inv MCS. destruct bb as [hd bdy ex]; simpl in *. subst. eapply transl_blocks_distrib in TRANS; [| simpl; discriminate]. - destruct TRANS as (TRANS1 & TRANS2). monadInv TRANS1. - inv EQ1. inv EQ. unfold gen_bblocks in H0; simpl in H0. inv H0. - esplit; esplit. esplit. 2: esplit. 3: esplit. - + simpl; auto. - + econstructor; eauto. inv AG0. econstructor; eauto. intro. Simpl. - + inv AT. econstructor; eauto. unfold nextblock; unfold size; simpl. - destruct tbb as [thd tbdy tex]; simpl. - eapply transl_blocks_distrib in H3. destruct H3 as (H31 & H32). monadInv H31. simpl in EQ. simpl in EQ1. - inv EQ1. inv H5. 2: simpl; discriminate. - simpl. rewrite FIND in H0. inv H0. rewrite H32 in TRANS2. inv TRANS2. - destruct bdy as [|i bdy]. - * inv EQ. Simpl. rewrite <- H1. rewrite <- H. econstructor; eauto. - assert (H42: size {| header := thd; body := nil; exit := None |} = 1) by (simpl; auto). - rewrite <- H42. eapply code_tail_next_int. - eapply transf_function_no_overflow; eauto. - eauto. - * apply transl_basic_code_length in EQ. destruct tbdy as [|i' tbdy]. simpl in EQ. discriminate. - Simpl. rewrite <- H1. rewrite <- H. econstructor; eauto. - assert (H42: size {| header := thd; body := i' ::i tbdy; exit := None |} = Z.of_nat (length (i' ::i tbdy))). - unfold size; simpl; auto. rewrite Nat.add_0_r. auto. - rewrite Nat.add_0_r. rewrite <- H42. eapply code_tail_next_int. - eapply transf_function_no_overflow; eauto. - eauto. - + apply plus_one. inv AT. econstructor; eauto. eapply functions_transl; eauto. - eapply find_bblock_tail; eauto. - unfold exec_bblock. rewrite EBDY. - eapply transl_blocks_distrib in H3; [|simpl; discriminate]. destruct H3 as [H31 H32]. - destruct tbb as [thd tbdy tex]; simpl in H31. monadInv H31. simpl. inv EQ1. inv EQ. inv H5. simpl. auto. -Unshelve. - all: destruct TODO. + intros. monadInv H. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. + - simpl; eauto. Qed. (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': - forall sf f sp bb bb' rs m rs' m' t s'' c S1, + forall sf f sp bb bb' rs m rs' m' s'' c S1, body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> - bb' = remove_body bb -> - exit_step return_address_offset ge (Machblock.exit bb') (Machblock.State sf f sp (bb' :: c) rs' m') t s'' -> + bb' = mb_remove_body bb -> + 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 t S2 /\ match_states s'' S2. + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. Proof. intros. inversion H2. subst. remember (Machblock.State sf f sp (bb::c) rs m) as mbs. - remember (State rs0 m'0) as abs. - exploit match_state_codestate; eauto. inv AT. auto. + remember (State rs0 m'0) as abs. inversion AT. + exploit transl_blocks_nonil; eauto. intros (tbb & tc' & ?). subst. rename tc' into tc. + exploit match_state_codestate; eauto. intros (S1' & MCS & MAS & cseq). subst. exploit step_simu_body; eauto. - intros (S1'' & rs1 & m1 & S1''eq & EBD & MCS' & tbb' & tc' & tceq & PRES). - subst. exploit step_simu_control; eauto. -Admitted. (* TODO - fix the proof with the new step_simulation_control *) -(* eauto. - intros (rs2 & m2 & EBB & MCS'' & MAB' & PSTEP). subst. - exists (State rs2 m2). split; auto. - eapply match_codestate_state; eauto. -Unshelve. - destruct TODO. -Qed. - *) - *) -(* Previous attempt at simulation_control and simulation_body - -Lemma step_simulation_control: - forall (bb: Machblock.bblock) sf f sp bb c rs' m' t s' (S1' S2': state), - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb::c) rs' m') t s' -> - match_states (Machblock.State sf f sp (bb :: c) rs' m') S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states s' S2'. -Proof. -Admitted. - -Lemma step_simulation_body: - forall body hd sf f sp bb bb' rs m rs' m' (S1' S2': state) s' t c, - body <> nil -> - bb = {| MB.header := hd; MB.body := body; MB.exit := None |} -> - body_step ge sf f sp body rs m rs' m' -> - bb' = remove_body bb -> - s' = (Machblock.State sf f sp (bb' :: c) rs' m') -> - match_states (Machblock.State sf f sp (bb::c) rs m) S1' -> - exists S2': state, step tge S1' t S2' /\ match_states s' S2' /\ t=E0. -Proof. - induction body as [|bi body]. - - intros. contradict H; simpl; auto. - - intros. destruct body as [|bi' body]. - + clear IHbody H. - destruct TODO. (* proof of individual instructions *) - + inv H1. - exploit IHbody. eauto. discriminate. 2: eapply H12. eauto. eauto. - (* 2: eapply H4. *) -Admitted. - -(* Alternative form of step_simulation_bblock, easier to prove *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' rs m rs' m' t S1' s' c, - body_step ge sf f sp (Machblock.body bb) rs m rs' m' -> - bb' = remove_body bb -> - exit_step return_address_offset ge (Machblock.exit bb') (Machblock.State sf f sp (bb' :: c) rs' m') t s' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states s' S2'. -Proof. - intros. - exploit step_simulation_body; eauto. intros. destruct H3 as (S2' & H31 & H32 & H33). - exploit step_simulation_control; eauto. intros. destruct H3 as (S3' & H41 & H42). - econstructor. econstructor. econstructor. - eapply H31. apply plus_star. eapply H41. - erewrite H33. traceEq. auto. + intros (rs2 & m2 & tbb' & EXES & MCS' & Hexit). + + remember (mb_remove_body bb) as bb'. + assert (MB.body bb' = nil). + subst. destruct bb as [hd bdy ex]; simpl; auto. + exploit functions_translated; eauto. intros (tf0 & ? & ?). monadInv H9. + exploit step_simu_control; eauto. + econstructor; eauto. erewrite exec_straight_pc; eauto. + assert (x = tf) by congruence. subst x. eauto. + + intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). + exploit exec_straight_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. + rewrite Hexit in EXECR. + exploit (exec_straight_bblock); eauto. intro EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. + eapply plus_one. eapply exec_step_internal; eauto. + assert (x = tf) by congruence. subst x. eapply find_bblock_tail; eauto. Qed. -*) -(* Lemma step_simulation_bblock: - forall sf f sp bb ms m ms' m' t S2 c, +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' -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') t S2 -> + 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' t S2' /\ match_states s' S2'. + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. Proof. - intros. eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. unfold remove_body; simpl. + intros. eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. inv H0. - simpl in *. subst. econstructor. inv H2; try (econstructor; eauto; fail). - simpl in *. subst. econstructor. Qed. - *) + +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + Theorem step_simulation: forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1595,7 +1422,8 @@ Proof. induction 1; intros. - (* bblock *) - left. (* eapply step_simulation_bblock; eauto. *) destruct TODO. + left. destruct TODO. + (* TODO - change the trace thing *) - (* internal function *) inv MS. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 81dd36b5..5c2d6f02 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -754,7 +754,7 @@ Proof. auto. Qed. -Lemma exec_straight_pc: +(* Lemma exec_straight_pc': forall c rs1 m1 rs2 m2, exec_straight c rs1 m1 nil rs2 m2 -> rs2 PC = rs1 PC. @@ -764,6 +764,18 @@ Proof. - 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 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. Qed. Lemma exec_straight_through: @@ -777,11 +789,11 @@ Proof. intros. subst. destruct i. - constructor 1. + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - + rewrite <- (exec_straight_pc c rs1 m1 rs2 m2'); auto. + + 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) rs1 m1 rs2 m2'); auto. + + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto. Qed. Lemma exec_straight_through_singleinst: -- cgit From 7e02f98ae8cb37c9d84df6d43b05104346fda691 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 12 Oct 2018 10:57:11 +0200 Subject: Separating the case of MBbuiltin from the rest --- mppa_k1c/Asmblockgenproof.v | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 7f54b874..0c16bffc 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1264,6 +1264,7 @@ Qed. Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 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) -> cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> @@ -1274,24 +1275,24 @@ Theorem step_simu_control: /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 /\ match_states S'' (State rs4 m4)). Proof. - intros until cs2. intros ? FIND ? MCS MAS ESTEP. inv ESTEP. + intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. - inv MCS. inv MAS. destruct ctl. + (* MBcall *) - exploit transl_blocks_distrib; eauto. rewrite <- H1. discriminate. + exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. destruct tbb' as [hd' bdy' ex']; simpl in *. subst. destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H2. + 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 H12. - * (* Indirect call *) inv H0. + * (* Indirect call *) inv H1. * (* Direct call *) - monadInv H0. + 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). @@ -1309,7 +1310,8 @@ Proof. + (* MBtailcall *) destruct TODO. + (* MBbuiltin *) - destruct TODO. + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + (* MBgoto *) destruct TODO. + (* MBcond *) @@ -1319,7 +1321,7 @@ Proof. + (* MBreturn *) destruct TODO. - inv MCS. inv MAS. - exploit transl_blocks_distrib; eauto. rewrite <- H2. discriminate. + exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. intros (c0 & c' & TBB & TCT & BEQ & EXEQ). destruct bb' as [hd' bdy' ex']; simpl in *. subst. inv TBB. inv TCT. simpl in *. @@ -1362,14 +1364,15 @@ Lemma step_simulation_bblock': forall sf f sp bb bb' rs m rs' m' s'' c S1, 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. inversion H2. subst. + intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. remember (Machblock.State sf f sp (bb::c) rs m) as mbs. remember (State rs0 m'0) as abs. inversion AT. - exploit transl_blocks_nonil; eauto. intros (tbb & tc' & ?). subst. rename tc' into tc. + exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. exploit match_state_codestate; eauto. intros (S1' & MCS & MAS & cseq). subst. exploit step_simu_body; eauto. @@ -1378,7 +1381,7 @@ Proof. remember (mb_remove_body bb) as bb'. assert (MB.body bb' = nil). subst. destruct bb as [hd bdy ex]; simpl; auto. - exploit functions_translated; eauto. intros (tf0 & ? & ?). monadInv H9. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. exploit step_simu_control; eauto. econstructor; eauto. erewrite exec_straight_pc; eauto. assert (x = tf) by congruence. subst x. eauto. @@ -1396,14 +1399,16 @@ 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. eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. - inv H0. - - simpl in *. subst. econstructor. inv H2; try (econstructor; eauto; fail). - - simpl in *. subst. econstructor. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. destruct bb as [hd bdy ex]; simpl in *. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. Qed. Definition measure (s: MB.state) : nat := @@ -1422,8 +1427,11 @@ Proof. induction 1; intros. - (* bblock *) - left. destruct TODO. - (* TODO - change the trace thing *) + 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). + + destruct TODO. (* MBbuiltin *) + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - (* internal function *) inv MS. -- cgit From 48d4481b6bd246e8912b3d01d98e0bc297f645de Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 12 Oct 2018 18:23:12 +0200 Subject: Stuck on proving step_simu_body --- mppa_k1c/Asmblockgen.v | 11 +- mppa_k1c/Asmblockgenproof.v | 3210 ++++++++++++++++++++++--------------------- 2 files changed, 1630 insertions(+), 1591 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 28941e22..fce2cb47 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -850,13 +850,18 @@ Local Obligation Tactic := bblock_auto_correct. (** 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 => {| header := hd; body := Pnop::(c ++ (extract_basic ctl)); exit := None |} :: nil + | None => {| header := hd; body := (c ++ (Pnop :: extract_basic ctl)); exit := None |} :: nil (* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) - | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := Pnop::c; exit := None |}) :: + | Some (PExpand (Pbuiltin ef args res)) => ({| header := hd; body := c++(Pnop::nil); exit := None |}) :: ((PExpand (Pbuiltin ef args res)) ::b nil) - | Some (PCtlFlow i) => {| header := hd; body := Pnop :: (c ++ (extract_basic ctl)); exit := Some (PCtlFlow i) |} :: nil + | Some (PCtlFlow i) => {| header := hd; body := (c ++ (Pnop :: extract_basic ctl)); exit := Some (PCtlFlow i) |} :: nil end . +Next Obligation. + intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. +Qed. Next Obligation. + intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. +Qed. Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := do c <- transl_basic_code' f fb.(Machblock.body) true; diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 0c16bffc..c89c5177 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,1588 +1,1622 @@ -(* *********************************************************************) -(* *) -(* 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 Asmgen Asmgenproof0 Asmgenproof1. *) -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. - -Module MB := Machblock. -Module AB := Asmblock. - -Definition match_prog (p: Machblock.program) (tp: Asmblock.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: Asmblock.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. - -(* -Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inv H. - eapply exec_straight_steps_1; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c ep tf tc c' ep' tc' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - transl_code f c' ep' = OK tc' -> - exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. -Proof. - intros. inv H. - exploit exec_straight_steps_2; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - *) -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -(* Remark loadimm32_label: - forall r n k, tail_nolabel k (loadimm32 r n k). -Proof. - intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm32_label: labels. - -Remark opimm32_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm32 op opimm r1 r2 n k). -Proof. - intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm32_label: labels. - -Remark loadimm64_label: - forall r n k, tail_nolabel k (loadimm64 r n k). -Proof. - intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm64_label: labels. - -Remark cast32signed_label: - forall rd rs k, tail_nolabel k (cast32signed rd rs k). -Proof. - intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. -Qed. -Hint Resolve cast32signed_label: labels. - -Remark opimm64_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm64 op opimm r1 r2 n k). -Proof. - intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm64_label: labels. - -Remark addptrofs_label: - forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). -Proof. - unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. - apply opimm64_label; TailNoLabel. -Qed. -Hint Resolve addptrofs_label: labels. -(* -Remark transl_cond_float_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_float; intros. destruct c; inv H; exact I. -Qed. - -Remark transl_cond_single_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_single; intros. destruct c; inv H; exact I. -Qed. -*) -Remark transl_cbranch_label: - forall cond args lbl k c, - transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. -(* Ccomp *) - - unfold transl_comp; TailNoLabel. -(* Ccompu *) - - unfold transl_comp; TailNoLabel. -(* Ccompimm *) - - destruct (Int.eq n Int.zero); TailNoLabel. - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. -(* Ccompuimm *) - - unfold transl_opt_compuimm. - remember (select_comp n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; - destruct (Int.eq n Int.zero); destruct c0; discriminate. - + unfold loadimm32; - destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. -(* Ccompl *) - - unfold transl_compl; TailNoLabel. -(* Ccomplu *) - - unfold transl_compl; TailNoLabel. -(* Ccomplimm *) - - destruct (Int64.eq n Int64.zero); TailNoLabel. - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. -(* Ccompluimm *) - - unfold transl_opt_compluimm. - remember (select_compl n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; - destruct (Int64.eq n Int64.zero); destruct c0; discriminate. - + unfold loadimm64; - destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. -Qed. - -(* -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -*) - -Remark transl_cond_op_label: - forall cond args r k c, - transl_cond_op cond r args k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. -- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. -Qed. - -Remark transl_op_label: - forall op args r k c, - transl_op op args r k = OK c -> tail_nolabel k c. -Proof. -Opaque Int.eq. - unfold transl_op; intros; destruct op; TailNoLabel. -(* Omove *) -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -(* Oaddrsymbol *) -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. -(* Oaddimm32 *) -- apply opimm32_label; intros; exact I. -(* Oandimm32 *) -- apply opimm32_label; intros; exact I. -(* Oorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oxorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oshrximm *) -- destruct (Int.eq n Int.zero); TailNoLabel. -(* Oaddimm64 *) -- apply opimm64_label; intros; exact I. -(* Oandimm64 *) -- apply opimm64_label; intros; exact I. -(* Oorimm64 *) -- apply opimm64_label; intros; exact I. -(* Oxorimm64 *) -- apply opimm64_label; intros; exact I. -(* Ocmp *) -- eapply transl_cond_op_label; eauto. -Qed. - -(* -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -- destruct (Float.eq_dec n Float.zero); TailNoLabel. -- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. -+ TailNoLabel. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- eapply transl_cond_op_label; eauto. -*) - -Remark indexed_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) base ofs k, - (forall r o, nolabel (mk_instr r o)) -> - tail_nolabel k (indexed_memory_access mk_instr base ofs k). -Proof. - unfold indexed_memory_access; intros. - (* destruct Archi.ptr64. *) - destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. - (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) -Qed. - -Remark loadind_label: - forall base ofs ty dst k c, - loadind base ofs ty dst k = OK c -> tail_nolabel k c. -Proof. - unfold loadind; intros. - destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark storeind_label: - forall src base ofs ty k c, - storeind src base ofs ty k = OK c -> tail_nolabel k c. -Proof. - unfold storeind; intros. - destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark loadind_ptr_label: - forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. - -Remark storeind_ptr_label: - forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. - -Remark transl_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) addr args k c, - (forall r o, nolabel (mk_instr r o)) -> - transl_memory_access mk_instr addr args k = OK c -> - tail_nolabel k c. -Proof. - unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. -Qed. - -Remark make_epilogue_label: - forall f k, tail_nolabel k (make_epilogue f k). -Proof. - unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. -Qed. - -Lemma transl_instr_label: - forall f i ep k c, - transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. -Proof. - unfold transl_instr; intros; destruct i; TailNoLabel. -(* loadind *) -- eapply loadind_label; eauto. -(* storeind *) -- eapply storeind_label; eauto. -(* Mgetparam *) -- destruct ep. eapply loadind_label; eauto. - eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. -(* transl_op *) -- eapply transl_op_label; eauto. -(* transl_load *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -(* transl store *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; TailNoLabel. -- destruct s0; monadInv H; eapply tail_nolabel_trans - ; [eapply make_epilogue_label|TailNoLabel]. -- eapply transl_cbranch_label; eauto. -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -Qed. -(* - - -- eapply transl_op_label; eauto. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -*) - -Lemma transl_instr_label': - forall lbl f i ep k c, - transl_instr f i ep k = OK c -> - find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply B). - intros. subst c. simpl. auto. -Qed. - -Lemma transl_code_label: - forall lbl f c ep tc, - transl_code f c ep = OK tc -> - match Mach.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). - generalize (Mach.is_label_correct lbl a). - destruct (Mach.is_label lbl a); intros. - subst a. simpl in EQ. exists x; auto. - eapply IHc; eauto. -Qed. - -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match Mach.find_label lbl f.(Mach.fn_code) with - | None => find_label lbl tf.(fn_code) = None - | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. - (* destruct B. *) - eapply transl_code_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 -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros [tc [A B]]. - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. -*) - -(** Existence of return addresses *) - -(* 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 f0 tf H0. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - monadInv EQ. simpl. - eapply ex_intro; constructor 1; eauto with coqlib. - - 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. -*) - -(* -Lemma exec_straight_steps: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists rs2, - exec_straight tge tf c rs1 m1' k rs2 m2' - /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c ms2 m2) st'. -Proof. - intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B C]]]. - exists (State rs2 m2'); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. -*) - -(* -Lemma exec_straight_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. - -Lemma exec_straight_opt_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - inv A. -- exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -- exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. *) - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the 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 R10) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of R10). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. *) - -(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) -(* -Theorem step_simulation: - forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros; inv MS. - -- (* Mlabel *) - left; eapply exec_straight_steps; eauto; intros. - monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. apply agree_nextinstr; auto. simpl; congruence. - -- (* Mgetstack *) - unfold load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto with asmgen. congruence. - simpl; congruence. - - -- (* Msetstack *) - unfold store_stack in H. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - left; eapply exec_straight_steps; eauto. - rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - inversion TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. - exists rs'; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. - -- (* Mgetparam *) - assert (f0 = f) by congruence; subst f0. - unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. -(* Opaque loadind. *) - left; eapply exec_straight_steps; eauto; intros. monadInv TR. - destruct ep. -(* GPR31 contains parent *) - exploit loadind_correct. eexact EQ. - instantiate (2 := rs0). rewrite DXP; eauto. congruence. - intros [rs1 [P [Q R]]]. - exists rs1; split. eauto. - split. 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. congruence. intros [rs1 [P [Q R]]]. - exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. - intros [rs2 [S [T U]]]. - exists rs2; split. eapply exec_straight_trans; eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs1#FP <- (rs2#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. -- (* Mop *) - assert (eval_operation tge sp op (map rs args) m = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. split. auto. - apply agree_set_undef_mreg with rs0; 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. - -- (* Mload *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - inversion TR. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. congruence. - intros; auto with asmgen. - simpl; congruence. - - -- (* Mstore *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - left; eapply exec_straight_steps; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - exists rs2; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. - -- (* Mcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct ros as [rf|fid]; simpl in H; monadInv H5. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. -*) -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. -*) -+ (* Direct call *) - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - 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 H. auto. } - -- (* Mbuiltin *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_builtin. eauto. eauto. - eapply find_instr_tail; eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x). - unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H1. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. - congruence. - -- (* Mgoto *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H4. - exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. - left; exists (State rs' m'); split. - apply plus_one. econstructor; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - econstructor; eauto. - eapply agree_exten; eauto with asmgen. - congruence. -- (* Mcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_opt_steps_goto; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exists jmp; exists k; exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - exact B. -- (* Mcond false *) - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). - exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - simpl. congruence. -- (* Mjumptable *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H6. -(* - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H5); intro NOOV. - exploit find_label_goto_label. eauto. eauto. - instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). - Simpl. eauto. - eauto. - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H. intros LD; inv LD. - left; econstructor; split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail; eauto. - simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. - econstructor; eauto. - eapply agree_undef_regs; eauto. - simpl. intros. rewrite C; auto with asmgen. Simpl. - congruence. -*) -- (* Mreturn *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. simpl in H6; monadInv H6. - assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - -- (* internal function *) - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. - unfold store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i - Pget GPR8 RA ::i - storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. - set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPR8 = rs0 RA). { apply V'. } - assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - rewrite H3. rewrite H4. - (* change (rs' GPR8) with (rs0 RA). *) - rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. - congruence. congruence. - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: - exec_straight tge tf - tf.(fn_code) rs0 m' - x0 rs3 m3'). - { change (fn_code tf) with tfbody; unfold tfbody. - apply exec_straight_step with rs2 m2'. - unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. - reflexivity. - eapply exec_straight_trans. - - eexact U'. - - eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite V. - assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H6; 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 V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. - -- (* external function *) - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. apply agree_set_pair; auto. - -- (* return *) - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. -*) - -Inductive match_states: Machblock.state -> Asmblock.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) - (Asmblock.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) - (Asmblock.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) - (Asmblock.State rs m'). - -Inductive codestate: Type := - | Codestate: state -> list AB.bblock -> option bblock -> codestate. - -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m m' rs f tc ep c bb tbb tbb' - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (TRANS: transl_blocks f (bb::c) = OK (tbb::tc)) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) - | match_codestate_call: - forall s ms m m' rs tc - (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_codestate fb (Machblock.Callstate s fb ms m) - (Codestate (Asmblock.State rs m') tc None) - | match_codestate_return: - forall s ms m m' rs tc - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_codestate fb (Machblock.Returnstate s ms m) - (Codestate (Asmblock.State rs m') tc None). - -Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := - | match_asmblock_some: - forall rs f tf tc m tbb tbb' ofs - (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_asmblock fb (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) (Asmblock.State rs m) -. - -Theorem match_codestate_state: - forall mbs abs fb cs rs m tbb tc, - cs = Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb) -> - match_codestate fb mbs cs -> - match_asmblock fb cs abs -> - match_states mbs abs. -Proof. - intros until tc. intros ? MCS MAB. - inv MCS; inv MAB. inv H1. - - rewrite FIND0 in FIND. inv FIND. -(* rewrite FIND0 in FIND. inv FIND. *) - econstructor; eauto. rewrite PCeq. (* inv AT. *) econstructor; eauto. - - discriminate. - - discriminate. -Qed. - -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m rs m' tbb tc tf ep f, - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - abs = (Asmblock.State rs m') -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_blocks f (bb::c) = OK (tbb::tc) -> - transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> - match_states mbs abs -> - exists cs, (match_codestate fb mbs cs /\ match_asmblock fb cs abs - /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). -Proof. - intros. inv H4; try discriminate. - inv H6. inv H5. rewrite FIND in H1. inv H1. - esplit. repeat split. - econstructor. 4: eapply H2. all: eauto. (* inv H3. eapply H1. *) - inv AT. - econstructor; eauto. - congruence. -Qed. - -Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := Pnop::nil; AB.exit := AB.exit bb |}. -Next Obligation. - unfold wf_bblock. unfold non_empty_bblock. left; discriminate. -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::nil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Axiom TODO: False. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc, - transl_blocks f (bb::c) = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb = OK (tbb :: nil) - /\ transl_blocks f c = OK tc. -Proof. - intros. destruct bb as [hd bdy ex]. simpl in *. - monadInv H. monadInv EQ. simpl in *. - destruct ex. - - destruct c0. - + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + destruct TODO. (* TODO - requires Sylvain black magic *) - + simpl in EQ. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + simpl in EQ. unfold transl_cbranch in EQ. destruct c0; destruct c. - all: try ( - repeat (destruct l; try discriminate); - monadInv EQ; simpl in *; inv H1; - unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; rewrite EQ; simpl; - unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( - simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; - rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( - simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; - rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. - rewrite EQ2; simpl. unfold gen_bblocks; simpl. unfold transl_opt_compuimm in *. - destruct (select_comp n c0). destruct c; try (simpl; inv H1; auto). - unfold transl_comp in *. simpl. inv H1. auto. - * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl. rewrite EQ0; simpl. - rewrite EQ2; simpl. unfold gen_bblocks in *. simpl in *. unfold transl_opt_compuimm in *. - destruct (select_comp n c0). destruct c1; try (simpl; inv H1; auto). simpl in *. inv H1. auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; - unfold transl_opt_compluimm in *; - destruct (select_compl n c0) eqn:SEL; try (destruct c; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - monadInv EQ. rewrite EQ2; simpl. unfold gen_bblocks in *; simpl in *. - unfold transl_opt_compluimm in *. destruct (select_compl n c0); try (destruct c1; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). - + simpl in EQ. discriminate. - + simpl in EQ. inv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. unfold gen_bblocks in *. - simpl in *. inv H1; auto. - - monadInv EQ. simpl in H1. inv H1. unfold transl_block. simpl. rewrite EQ0. simpl. - unfold gen_bblocks. simpl. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = Pnop :: (tbdy ++ (extract_basic tex)) - /\ exit tbb = extract_ctl tex. -Proof. - intros. unfold gen_bblocks in H. - destruct (extract_ctl tex). - - destruct c. - + destruct i. inv H. - + inv H. auto. - - inv H. auto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb tbb, - transl_block f bb = OK (tbb :: nil) -> - exists c c', - transl_basic_code' f (MB.body bb) true = OK c - /\ transl_instr_control f (MB.exit bb) true = OK c' - /\ body tbb = Pnop :: (c ++ (extract_basic c')) - /\ exit tbb = extract_ctl c'. -Proof. - intros. monadInv H. - eexists. eexists. split; eauto. split; eauto. - eapply gen_bblocks_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. - -Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 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) -> - cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmblock fb cs2 (Asmblock.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_straight tge (body tbb') rs2 m2 nil rs3 m3 - /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. - - inv MCS. inv MAS. - destruct ctl. - + (* MBcall *) - exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) - intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. - intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. - destruct tbb' as [hd' bdy' ex']; simpl in *. subst. - 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 H12. - * (* Indirect call *) inv H1. - * (* 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. econstructor; eauto. econstructor; eauto. - remember (nextblock _ _) as rs'1. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - exploit nextblock_preserves. eapply Heqrs'1. eauto. auto. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H12. eauto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct TODO. - + (* MBbuiltin *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct TODO. - + (* MBcond *) - destruct TODO. - + (* MBjumptable *) - destruct TODO. - + (* MBreturn *) - destruct TODO. - - inv MCS. inv MAS. - exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. - intros (c0 & c' & TBB & TCT & BEQ & EXEQ). - destruct bb' as [hd' bdy' ex']; simpl in *. subst. inv TBB. inv TCT. simpl in *. - repeat eexists. rewrite BEQ. econstructor; eauto. econstructor; eauto. - rewrite EXEQ. econstructor; eauto. econstructor; eauto. - unfold nextblock. 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. -Qed. - -Theorem step_simu_body: - forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', - match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - exists rs2 m2 tbb', - exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 - /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') - (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) - /\ exit tbb' = exit tbb. -Proof. - -Admitted. - -Lemma transl_blocks_nonil: - forall f bb c tc, - transl_blocks f (bb::c) = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. - intros. monadInv H. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. - - simpl; eauto. -Qed. - -(* Alternative form of step_simulation_bblock, easier to prove *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' rs m rs' m' s'' c S1, - 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 BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. - remember (Machblock.State sf f sp (bb::c) rs m) as mbs. - remember (State rs0 m'0) as abs. inversion AT. - exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - exploit match_state_codestate; eauto. - intros (S1' & MCS & MAS & cseq). subst. - exploit step_simu_body; eauto. - intros (rs2 & m2 & tbb' & EXES & MCS' & Hexit). - - remember (mb_remove_body bb) as bb'. - assert (MB.body bb' = nil). - subst. destruct bb as [hd bdy ex]; simpl; auto. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - exploit step_simu_control; eauto. - econstructor; eauto. erewrite exec_straight_pc; eauto. - assert (x = tf) by congruence. subst x. eauto. - - intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). - exploit exec_straight_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. - rewrite Hexit in EXECR. - exploit (exec_straight_bblock); eauto. intro EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. - eapply plus_one. eapply exec_step_internal; eauto. - assert (x = tf) by congruence. subst x. 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. destruct bb as [hd bdy ex]; simpl in *. - 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. - -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). - + destruct TODO. (* MBbuiltin *) - + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b - Pget GPR8 RA ::b - storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) - (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - exploit (Pget_correct tge GPR8 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) GPR8 nil rs'' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPR8 = rs0 RA). { apply V'. } - assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. } - assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. } - rewrite H4. rewrite H3. rewrite H6. rewrite H5. - (* change (rs' GPR8) with (rs0 RA). *) - rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. - congruence. congruence. - intros (rs3 & U & V). - exploit (exec_straight_through_singleinst); eauto. - intro W. - remember (nextblock _ rs3) as rs3'. - assert (EXEC_PROLOGUE: - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3'). - { change (fn_blocks tf) with tfbody; unfold tfbody. - apply exec_straight_blocks_step with rs2 m2'. - unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity. - reflexivity. - eapply exec_straight_blocks_trans. - - eexact W'. - - eexact W. } - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. 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. unfold tfbody. simpl bblock_single_inst. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_nextblock. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto. - assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPR8 -> 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. - auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite Heqrs''. Simpl. - rewrite H4 by auto with asmgen. reflexivity. -- (* 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. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Unshelve. - exact true. -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) (AB.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 Asmgen Asmgenproof0 Asmgenproof1. *) +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. + +Module MB := Machblock. +Module AB := Asmblock. + +Definition match_prog (p: Machblock.program) (tp: Asmblock.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: Asmblock.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. + +(* +Lemma exec_straight_exec: + forall fb f c ep tf tc c' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + exec_straight tge tf tc rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inv H. + eapply exec_straight_steps_1; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c ep tf tc c' ep' tc' rs m rs' m', + transl_code_at_pc ge (rs PC) fb f c ep tf tc -> + transl_code f c' ep' = OK tc' -> + exec_straight tge tf tc rs m tc' rs' m' -> + transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. +Proof. + intros. inv H. + exploit exec_straight_steps_2; eauto. + eapply transf_function_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + *) +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +(* Remark loadimm32_label: + forall r n k, tail_nolabel k (loadimm32 r n k). +Proof. + intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) +Qed. +Hint Resolve loadimm32_label: labels. + +Remark opimm32_label: + forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm32 op opimm r1 r2 n k). +Proof. + intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. +(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) +Qed. +Hint Resolve opimm32_label: labels. + +Remark loadimm64_label: + forall r n k, tail_nolabel k (loadimm64 r n k). +Proof. + intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) +Qed. +Hint Resolve loadimm64_label: labels. + +Remark cast32signed_label: + forall rd rs k, tail_nolabel k (cast32signed rd rs k). +Proof. + intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. +Qed. +Hint Resolve cast32signed_label: labels. + +Remark opimm64_label: + forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, + (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> + (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> + tail_nolabel k (opimm64 op opimm r1 r2 n k). +Proof. + intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. +(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) +Qed. +Hint Resolve opimm64_label: labels. + +Remark addptrofs_label: + forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). +Proof. + unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. + apply opimm64_label; TailNoLabel. +Qed. +Hint Resolve addptrofs_label: labels. +(* +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. +Qed. +*) +Remark transl_cbranch_label: + forall cond args lbl k c, + transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. +(* Ccomp *) + - unfold transl_comp; TailNoLabel. +(* Ccompu *) + - unfold transl_comp; TailNoLabel. +(* Ccompimm *) + - destruct (Int.eq n Int.zero); TailNoLabel. + unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. +(* Ccompuimm *) + - unfold transl_opt_compuimm. + remember (select_comp n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; + destruct (Int.eq n Int.zero); destruct c0; discriminate. + + unfold loadimm32; + destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. +(* Ccompl *) + - unfold transl_compl; TailNoLabel. +(* Ccomplu *) + - unfold transl_compl; TailNoLabel. +(* Ccomplimm *) + - destruct (Int64.eq n Int64.zero); TailNoLabel. + unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. +(* Ccompluimm *) + - unfold transl_opt_compluimm. + remember (select_compl n c0) as selcomp; destruct selcomp. + + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; + destruct (Int64.eq n Int64.zero); destruct c0; discriminate. + + unfold loadimm64; + destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. +Qed. + +(* +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +*) + +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. +Qed. + +Remark transl_op_label: + forall op args r k c, + transl_op op args r k = OK c -> tail_nolabel k c. +Proof. +Opaque Int.eq. + unfold transl_op; intros; destruct op; TailNoLabel. +(* Omove *) +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +(* Oaddrsymbol *) +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. +(* Oaddimm32 *) +- apply opimm32_label; intros; exact I. +(* Oandimm32 *) +- apply opimm32_label; intros; exact I. +(* Oorimm32 *) +- apply opimm32_label; intros; exact I. +(* Oxorimm32 *) +- apply opimm32_label; intros; exact I. +(* Oshrximm *) +- destruct (Int.eq n Int.zero); TailNoLabel. +(* Oaddimm64 *) +- apply opimm64_label; intros; exact I. +(* Oandimm64 *) +- apply opimm64_label; intros; exact I. +(* Oorimm64 *) +- apply opimm64_label; intros; exact I. +(* Oxorimm64 *) +- apply opimm64_label; intros; exact I. +(* Ocmp *) +- eapply transl_cond_op_label; eauto. +Qed. + +(* +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. ++ TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); TailNoLabel. +- eapply transl_cond_op_label; eauto. +*) + +Remark indexed_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) base ofs k, + (forall r o, nolabel (mk_instr r o)) -> + tail_nolabel k (indexed_memory_access mk_instr base ofs k). +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64. *) + destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. + (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) +Qed. + +Remark loadind_label: + forall base ofs ty dst k c, + loadind base ofs ty dst k = OK c -> tail_nolabel k c. +Proof. + unfold loadind; intros. + destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark storeind_label: + forall src base ofs ty k c, + storeind src base ofs ty k = OK c -> tail_nolabel k c. +Proof. + unfold storeind; intros. + destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. +Qed. + +Remark loadind_ptr_label: + forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark storeind_ptr_label: + forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). +Proof. + intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. +Qed. + +Remark transl_memory_access_label: + forall (mk_instr: ireg -> offset -> instruction) addr args k c, + (forall r o, nolabel (mk_instr r o)) -> + transl_memory_access mk_instr addr args k = OK c -> + tail_nolabel k c. +Proof. + unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. +Qed. + +Remark make_epilogue_label: + forall f k, tail_nolabel k (make_epilogue f k). +Proof. + unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. +Qed. + +Lemma transl_instr_label: + forall f i ep k c, + transl_instr f i ep k = OK c -> + match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. +Proof. + unfold transl_instr; intros; destruct i; TailNoLabel. +(* loadind *) +- eapply loadind_label; eauto. +(* storeind *) +- eapply storeind_label; eauto. +(* Mgetparam *) +- destruct ep. eapply loadind_label; eauto. + eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. +(* transl_op *) +- eapply transl_op_label; eauto. +(* transl_load *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +(* transl store *) +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct s0; monadInv H; TailNoLabel. +- destruct s0; monadInv H; eapply tail_nolabel_trans + ; [eapply make_epilogue_label|TailNoLabel]. +- eapply transl_cbranch_label; eauto. +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +Qed. +(* + + +- eapply transl_op_label; eauto. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. +- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). +- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. +*) + +Lemma transl_instr_label': + forall lbl f i ep k c, + transl_instr f i ep k = OK c -> + find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. exploit transl_instr_label; eauto. + destruct i; try (intros [A B]; apply B). + intros. subst c. simpl. auto. +Qed. + +Lemma transl_code_label: + forall lbl f c ep tc, + transl_code f c ep = OK tc -> + match Mach.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). + generalize (Mach.is_label_correct lbl a). + destruct (Mach.is_label lbl a); intros. + subst a. simpl in EQ. exists x; auto. + eapply IHc; eauto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match Mach.find_label lbl f.(Mach.fn_code) with + | None => find_label lbl tf.(fn_code) = None + | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. + monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. + simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. + (* destruct B. *) + eapply transl_code_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 -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros [tc [A B]]. + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. +*) + +(** Existence of return addresses *) + +(* 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 f0 tf H0. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + monadInv EQ. simpl. + eapply ex_intro; constructor 1; eauto with coqlib. + - 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. +*) + +(* +Lemma exec_straight_steps: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists rs2, + exec_straight tge tf c rs1 m1' k rs2 m2' + /\ agree ms2 sp rs2 + /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c ms2 m2) st'. +Proof. + intros. inversion H2. subst. monadInv H7. + exploit H3; eauto. intros [rs2 [A [B C]]]. + exists (State rs2 m2'); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. +*) + +(* +Lemma exec_straight_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. + +Lemma exec_straight_opt_steps_goto: + forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', + match_stack ge s -> + Mem.extends m2 m2' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> + it1_is_parent ep i = false -> + (forall k c (TR: transl_instr f i ep k = OK c), + exists jmp, exists k', exists rs2, + exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' + /\ agree ms2 sp rs2 + /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> + exists st', + plus step tge (State rs1 m1') E0 st' /\ + match_states (Mach.State s fb sp c' ms2 m2) st'. +Proof. + intros. inversion H3. subst. monadInv H9. + exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. + generalize (functions_transl _ _ _ H7 H8); intro FN. + generalize (transf_function_no_overflow _ _ H8); intro NOOV. + inv A. +- exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +- exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + exploit find_label_goto_label; eauto. + intros [tc' [rs3 [GOTO [AT' OTH]]]]. + exists (State rs3 m2'); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. eauto. + rewrite C. eexact GOTO. + traceEq. + econstructor; eauto. + apply agree_exten with rs2; auto with asmgen. + congruence. +Qed. *) + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the 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 R10) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of R10). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. *) + +(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) +(* +Theorem step_simulation: + forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + +- (* Mlabel *) + left; eapply exec_straight_steps; eauto; intros. + monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split. apply agree_nextinstr; auto. simpl; congruence. + +- (* Mgetstack *) + unfold load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto with asmgen. congruence. + simpl; congruence. + + +- (* Msetstack *) + unfold store_stack in H. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + left; eapply exec_straight_steps; eauto. + rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. + inversion TR. + exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. + exists rs'; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. + +- (* Mgetparam *) + assert (f0 = f) by congruence; subst f0. + unfold load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. +(* Opaque loadind. *) + left; eapply exec_straight_steps; eauto; intros. monadInv TR. + destruct ep. +(* GPR31 contains parent *) + exploit loadind_correct. eexact EQ. + instantiate (2 := rs0). rewrite DXP; eauto. congruence. + intros [rs1 [P [Q R]]]. + exists rs1; split. eauto. + split. 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. congruence. intros [rs1 [P [Q R]]]. + exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. + intros [rs2 [S [T U]]]. + exists rs2; split. eapply exec_straight_trans; eauto. + split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs1#FP <- (rs2#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. +- (* Mop *) + assert (eval_operation tge sp op (map rs args) m = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. split. auto. + apply agree_set_undef_mreg with rs0; 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. + +- (* Mload *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + left; eapply exec_straight_steps; eauto; intros. simpl in TR. + inversion TR. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + exists rs2; split. eauto. + split. eapply agree_set_undef_mreg; eauto. congruence. + intros; auto with asmgen. + simpl; congruence. + + +- (* Mstore *) + assert (eval_addressing tge sp addr (map rs args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + left; eapply exec_straight_steps; eauto. + intros. simpl in TR. + inversion TR. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + exists rs2; split. eauto. + split. eapply agree_undef_regs; eauto with asmgen. + simpl; congruence. + +- (* Mcall *) + assert (f0 = f) by congruence. subst f0. + inv AT. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct ros as [rf|fid]; simpl in H; monadInv H5. +(* ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. +*) ++ (* Direct call *) + generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. + assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). + econstructor; eauto. + exploit return_address_offset_correct; eauto. intros; subst ra. + left; econstructor; split. + apply plus_one. eapply exec_step_internal. eauto. + eapply functions_transl; eauto. eapply find_instr_tail; eauto. + simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. + econstructor; eauto. + econstructor; eauto. + eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. rewrite <- H2. auto. + +- (* Mtailcall *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. + assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. + destruct ros as [rf|fid]; simpl in H; monadInv H7. +(* ++ (* Indirect call *) + assert (rs rf = Vptr f' Ptrofs.zero). + destruct (rs rf); try discriminate. + revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. + assert (rs0 x0 = Vptr f' Ptrofs.zero). + exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. +*) ++ (* Direct call *) + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + 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 H. auto. } + +- (* Mbuiltin *) + inv AT. monadInv H4. + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H3); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + left. econstructor; split. apply plus_one. + eapply exec_step_builtin. eauto. eauto. + eapply find_instr_tail; eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x). + unfold nextinstr. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H1. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextinstr. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. + congruence. + +- (* Mgoto *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H4. + exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. + left; exists (State rs' m'); split. + apply plus_one. econstructor; eauto. + eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; eauto. + econstructor; eauto. + eapply agree_exten; eauto with asmgen. + congruence. +- (* Mcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_opt_steps_goto; eauto. + intros. simpl in TR. + inversion TR. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exists jmp; exists k; exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + exact B. +- (* Mcond false *) + exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + inversion TR. + exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). + exists rs'. + split. eexact A. + split. apply agree_exten with rs0; auto with asmgen. + simpl. congruence. +- (* Mjumptable *) + assert (f0 = f) by congruence. subst f0. + inv AT. monadInv H6. +(* + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H5); intro NOOV. + exploit find_label_goto_label. eauto. eauto. + instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). + Simpl. eauto. + eauto. + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H. intros LD; inv LD. + left; econstructor; split. + apply plus_one. econstructor; eauto. + eapply find_instr_tail; eauto. + simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. + econstructor; eauto. + eapply agree_undef_regs; eauto. + simpl. intros. rewrite C; auto with asmgen. Simpl. + congruence. +*) +- (* Mreturn *) + assert (f0 = f) by congruence. subst f0. + inversion AT; subst. simpl in H6; monadInv H6. + assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. + intros (ofs' & P & Q). + left; econstructor; split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. + simpl. reflexivity. + traceEq. + (* match states *) + econstructor; eauto. + apply agree_set_other; auto with asmgen. + +- (* internal function *) + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. + unfold store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i + Pget GPR8 RA ::i + storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. + set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. + set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). + exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } + rewrite H3. rewrite H4. + (* change (rs' GPR8) with (rs0 RA). *) + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. + congruence. congruence. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: + exec_straight tge tf + tf.(fn_code) rs0 m' + x0 rs3 m3'). + { change (fn_code tf) with tfbody; unfold tfbody. + apply exec_straight_step with rs2 m2'. + unfold exec_instr. rewrite C. fold sp. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. + reflexivity. + eapply exec_straight_trans. + - eexact U'. + - eexact U. } + exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3 m3'); split. + eapply exec_straight_steps_1; eauto. omega. constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite V. + assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H6; 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 V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. + +- (* external function *) + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. apply agree_set_pair; auto. + +- (* return *) + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. +*) + +Inductive match_states: Machblock.state -> Asmblock.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) + (Asmblock.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) + (Asmblock.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) + (Asmblock.State rs m'). + +Inductive codestate: Type := + | Codestate: state -> list AB.bblock -> option bblock -> codestate. + +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m m' rs f tc ep c bb tbb tbb' + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (TRANS: transl_blocks f (bb::c) = OK (tbb::tc)) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) + | match_codestate_call: + forall s ms m m' rs tc + (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_codestate fb (Machblock.Callstate s fb ms m) + (Codestate (Asmblock.State rs m') tc None) + | match_codestate_return: + forall s ms m m' rs tc + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_codestate fb (Machblock.Returnstate s ms m) + (Codestate (Asmblock.State rs m') tc None). + +Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := + | match_asmblock_some: + forall rs f tf tc m tbb tbb' ofs + (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_asmblock fb (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) (Asmblock.State rs m) +. + +Theorem match_codestate_state: + forall mbs abs fb cs rs m tbb tc, + cs = Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb) -> + match_codestate fb mbs cs -> + match_asmblock fb cs abs -> + match_states mbs abs. +Proof. + intros until tc. intros ? MCS MAB. + inv MCS; inv MAB. inv H1. + - rewrite FIND0 in FIND. inv FIND. +(* rewrite FIND0 in FIND. inv FIND. *) + econstructor; eauto. rewrite PCeq. (* inv AT. *) econstructor; eauto. + - discriminate. + - discriminate. +Qed. + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m rs m' tbb tc tf ep f, + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + abs = (Asmblock.State rs m') -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_blocks f (bb::c) = OK (tbb::tc) -> + transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> + match_states mbs abs -> + exists cs, (match_codestate fb mbs cs /\ match_asmblock fb cs abs + /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). +Proof. + intros. inv H4; try discriminate. + inv H6. inv H5. rewrite FIND in H1. inv H1. + esplit. repeat split. + econstructor. 4: eapply H2. all: eauto. (* inv H3. eapply H1. *) + inv AT. + econstructor; eauto. + congruence. +Qed. + +Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := Pnop::nil; AB.exit := AB.exit bb |}. +Next Obligation. + unfold wf_bblock. unfold non_empty_bblock. left; discriminate. +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::nil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Axiom TODO: False. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc, + transl_blocks f (bb::c) = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb = OK (tbb :: nil) + /\ transl_blocks f c = OK tc. +Proof. + intros. destruct bb as [hd bdy ex]. simpl in *. + monadInv H. monadInv EQ. simpl in *. + destruct ex. + - destruct c0. + + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + destruct TODO. (* TODO - requires Sylvain black magic *) + + simpl in EQ. monadInv EQ. simpl in *. inv H1. + unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. + + simpl in EQ. unfold transl_cbranch in EQ. destruct c0; destruct c. + all: try ( + repeat (destruct l; try discriminate); + monadInv EQ; simpl in *; inv H1; + unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; rewrite EQ; simpl; + unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( + simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; + rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( + simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; + rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). + * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. + rewrite EQ2; simpl. unfold gen_bblocks; simpl. unfold transl_opt_compuimm in *. + destruct (select_comp n c0). destruct c; try (simpl; inv H1; auto). + unfold transl_comp in *. simpl. inv H1. auto. + * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl. rewrite EQ0; simpl. + rewrite EQ2; simpl. unfold gen_bblocks in *. simpl in *. unfold transl_opt_compuimm in *. + destruct (select_comp n c0). destruct c1; try (simpl; inv H1; auto). simpl in *. inv H1. auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + destruct (Int64.eq n Int64.zero); simpl in *. + all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; + unfold transl_opt_compluimm in *; + destruct (select_compl n c0) eqn:SEL; try (destruct c; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). + * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. + monadInv EQ. rewrite EQ2; simpl. unfold gen_bblocks in *; simpl in *. + unfold transl_opt_compluimm in *. destruct (select_compl n c0); try (destruct c1; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). + + simpl in EQ. discriminate. + + simpl in EQ. inv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. unfold gen_bblocks in *. + simpl in *. inv H1; auto. + - monadInv EQ. simpl in H1. inv H1. unfold transl_block. simpl. rewrite EQ0. simpl. + unfold gen_bblocks. simpl. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ (Pnop :: extract_basic tex) + /\ exit tbb = extract_ctl tex. +Proof. + intros. unfold gen_bblocks in H. + destruct (extract_ctl tex). + - destruct c. + + destruct i. inv H. + + inv H. auto. + - inv H. auto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb tbb, + transl_block f bb = OK (tbb :: nil) -> + exists c c', + transl_basic_code' f (MB.body bb) true = OK c + /\ transl_instr_control f (MB.exit bb) true = OK c' + /\ body tbb = c ++ (Pnop :: extract_basic c') + /\ exit tbb = extract_ctl c'. +Proof. + intros. monadInv H. + eexists. eexists. split; eauto. split; eauto. + eapply gen_bblocks_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. + +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 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) -> + cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmblock fb cs2 (Asmblock.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_straight tge (body tbb') rs2 m2 nil rs3 m3 + /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. + - inv MCS. inv MAS. + destruct ctl. + + (* MBcall *) + exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) + intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. + intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. + destruct tbb' as [hd' bdy' ex']; simpl in *. subst. + 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 H12. + * (* Indirect call *) inv H1. + * (* 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. econstructor; eauto. econstructor; eauto. + remember (nextblock _ _) as rs'1. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. + simpl. eapply agree_exten; eauto. intros. Simpl. + exploit nextblock_preserves. eapply Heqrs'1. eauto. auto. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H12. eauto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct TODO. + + (* MBbuiltin *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct TODO. + + (* MBcond *) + destruct TODO. + + (* MBjumptable *) + destruct TODO. + + (* MBreturn *) + destruct TODO. + - inv MCS. inv MAS. + exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) + intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. + intros (c0 & c' & TBB & TCT & BEQ & EXEQ). + destruct bb' as [hd' bdy' ex']; simpl in *. subst. inv TBB. inv TCT. simpl in *. + repeat eexists. rewrite BEQ. econstructor; eauto. econstructor; eauto. + rewrite EXEQ. econstructor; eauto. econstructor; eauto. + unfold nextblock. 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. +Qed. + +(* Lemma transl_blocks_body: + forall f bb c tbb tc + transl_blocks f (bb::c) = OK (tbb::tc) -> + + exists tbdy tbdy', + transl_basic_code' f (MB.body bb) true = OK (tbdy) + /\ transl_basic_code' f (MB.body (mb_remove_body bb)) true = OK (tbdy') + /\ body tbb = Pnop :: tbdy ++ tbdy'. +Proof. + intros. monadInv TBLS. monadInv EQ. exists x1. + unfold gen_bblocks in H0. destruct (extract_ctl x2). destruct c0. destruct i. + - inv H0. simpl. exists nil. rewrite app_nil_r. auto. + - inv H0. simpl. eexists. eauto. + - inv H0. simpl. eexists. eauto. +Qed. + *) + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Theorem step_simu_body': + forall s fb sp bb c ms m rs1 m1 tbb tc ms' m' bi bdy, + MB.body bb = bi :: bdy -> + basic_step ge s fb sp ms m bi ms' m' -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> + exists rs2 m2 tbb', + exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + /\ match_codestate fb (MB.State s fb sp (mb_remove_first bb :: c) ms' m') + (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) + /\ exit tbb' = exit tbb. +Proof. +Admitted. + +Theorem step_simu_body: + forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> + exists rs2 m2 tbb', + exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') + (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) + /\ exit tbb' = exit tbb. +Proof. + intros until m'. intros BSTEP MCS. inv BSTEP. + +Admitted. + +Lemma transl_blocks_nonil: + forall f bb c tc, + transl_blocks f (bb::c) = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros. monadInv H. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. + - simpl; eauto. +Qed. + +(* Alternative form of step_simulation_bblock, easier to prove *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' rs m rs' m' s'' c S1, + 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 BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. + remember (Machblock.State sf f sp (bb::c) rs m) as mbs. + remember (State rs0 m'0) as abs. inversion AT. + exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + exploit match_state_codestate; eauto. + intros (S1' & MCS & MAS & cseq). subst. + exploit step_simu_body; eauto. + intros (rs2 & m2 & tbb' & EXES & MCS' & Hexit). + + remember (mb_remove_body bb) as bb'. + assert (MB.body bb' = nil). + subst. destruct bb as [hd bdy ex]; simpl; auto. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + exploit step_simu_control; eauto. + econstructor; eauto. erewrite exec_straight_pc; eauto. + assert (x = tf) by congruence. subst x. eauto. + + intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). + exploit exec_straight_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. + rewrite Hexit in EXECR. + exploit (exec_straight_bblock); eauto. intro EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. + eapply plus_one. eapply exec_step_internal; eauto. + assert (x = tf) by congruence. subst x. 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. destruct bb as [hd bdy ex]; simpl in *. + 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. + +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). + + destruct TODO. (* MBbuiltin *) + + 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b + Pget GPR8 RA ::b + storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) + (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). + exploit (Pget_correct tge GPR8 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) GPR8 nil rs'' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPR8 = rs0 RA). { apply V'. } + assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. } + assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } + assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. } + rewrite H4. rewrite H3. rewrite H6. rewrite H5. + (* change (rs' GPR8) with (rs0 RA). *) + rewrite ATLR. + change (rs2 GPR12) with sp. eexact P. + congruence. congruence. + intros (rs3 & U & V). + exploit (exec_straight_through_singleinst); eauto. + intro W. + remember (nextblock _ rs3) as rs3'. + assert (EXEC_PROLOGUE: + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3'). + { change (fn_blocks tf) with tfbody; unfold tfbody. + apply exec_straight_blocks_step with rs2 m2'. + unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity. + reflexivity. + eapply exec_straight_blocks_trans. + - eexact W'. + - eexact W. } + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. 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. unfold tfbody. simpl bblock_single_inst. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_nextblock. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto. + assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPR8 -> 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. + auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + rewrite Heqrs''. Simpl. + rewrite H4 by auto with asmgen. reflexivity. +- (* 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. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Unshelve. + exact true. +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) (AB.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. -- cgit From 9ba6ffd3346136feef33d400596a3ca89f9e7260 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 12 Oct 2018 18:38:05 +0200 Subject: Disjonction des cas MB.body bb = nil ou non --- mppa_k1c/Asmblockgenproof.v | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c89c5177..67974529 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1372,11 +1372,12 @@ Theorem step_simu_body: forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', body_step ge s fb sp (MB.body bb) ms m ms' m' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - exists rs2 m2 tbb', - exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + (mb_remove_body bb = bb \/ + (exists rs2 m2 tbb', + (exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) - /\ exit tbb' = exit tbb. + /\ exit tbb' = exit tbb ))). Proof. intros until m'. intros BSTEP MCS. inv BSTEP. @@ -1409,8 +1410,9 @@ Proof. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. exploit match_state_codestate; eauto. intros (S1' & MCS & MAS & cseq). subst. - exploit step_simu_body; eauto. - intros (rs2 & m2 & tbb' & EXES & MCS' & Hexit). + exploit step_simu_body; eauto. intro STSIMUBODY. inv STSIMUBODY. + - (* mb_remove_body bb = bb *) destruct TODO. + - destruct H4 as (rs2 & m2 & tbb' & EXES & MCS' & Hexit). remember (mb_remove_body bb) as bb'. assert (MB.body bb' = nil). -- cgit From 3fb302f11ccb8e7196d01ec51104060be7c01055 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 15 Oct 2018 17:53:10 +0200 Subject: Réintroduction du Pnop, que si pas de body et d'exit. Réécriture du transl_bblocks_distrib MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 12 ++-- mppa_k1c/Asmblockgenproof.v | 139 ++++++++++++++++++++++---------------------- 2 files changed, 79 insertions(+), 72 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index fce2cb47..ad5bbe97 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -850,18 +850,22 @@ Local Obligation Tactic := bblock_auto_correct. (** 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 => {| header := hd; body := (c ++ (Pnop :: extract_basic ctl)); exit := None |} :: nil + | None => + match c with + | 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)) => ({| header := hd; body := c++(Pnop::nil); exit := None |}) :: ((PExpand (Pbuiltin ef args res)) ::b nil) - | Some (PCtlFlow i) => {| header := hd; body := (c ++ (Pnop :: extract_basic ctl)); exit := Some (PCtlFlow i) |} :: nil + | Some (PCtlFlow i) => {| header := hd; body := (c ++ extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil end . Next Obligation. intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. -Qed. Next Obligation. +Qed. (* Next Obligation. intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. -Qed. +Qed. *) Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := do c <- transl_basic_code' f fb.(Machblock.body) true; diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 67974529..fba22da4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1081,7 +1081,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (DXP: ep = true -> rs#FP = parent_sp s), match_codestate fb (Machblock.State s fb sp (bb::c) ms m) (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) - | match_codestate_call: +(* | match_codestate_call: forall s ms m m' rs tc (STACKS: match_stack ge s) (MEXT: Mem.extends m m') @@ -1097,7 +1097,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (AG: agree ms (parent_sp s) rs) (ATPC: rs PC = parent_ra s), match_codestate fb (Machblock.Returnstate s ms m) - (Codestate (Asmblock.State rs m') tc None). + (Codestate (Asmblock.State rs m') tc None) *). Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := | match_asmblock_some: @@ -1109,7 +1109,7 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := match_asmblock fb (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) (Asmblock.State rs m) . -Theorem match_codestate_state: +(* Theorem match_codestate_state: forall mbs abs fb cs rs m tbb tc, cs = Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb) -> match_codestate fb mbs cs -> @@ -1123,7 +1123,7 @@ Proof. econstructor; eauto. rewrite PCeq. (* inv AT. *) econstructor; eauto. - discriminate. - discriminate. -Qed. +Qed. *) Theorem match_state_codestate: forall mbs abs s fb sp bb c ms m rs m' tbb tc tf ep f, @@ -1145,10 +1145,11 @@ Proof. congruence. Qed. -Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := Pnop::nil; AB.exit := AB.exit bb |}. +(* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. Next Obligation. unfold wf_bblock. unfold non_empty_bblock. left; discriminate. Qed. + *) Definition mb_remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. @@ -1161,7 +1162,35 @@ Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. Qed. -Axiom TODO: False. +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex true = 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. + + simpl in TIC. destruct s0; try inversion TIC. simpl. eauto. + + simpl in TIC. destruct s0; try inversion TIC. simpl. eauto. + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + + simpl in TIC. monadInv TIC. simpl. eauto. + + simpl in TIC. unfold transl_cbranch in TIC. destruct c. + all: try ( destruct l; try (inv TIC; fail); destruct l; try (inv TIC; fail); destruct l; monadInv TIC; + simpl; eauto; try inv TIC). + * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. destruct (Int.eq n Int.zero); simpl; eauto. + * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. unfold transl_opt_compuimm. destruct (select_comp n c). + destruct c0; simpl; eauto. + simpl; eauto. + * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. destruct (Int64.eq n Int64.zero); simpl; eauto. + * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. unfold transl_opt_compluimm. destruct (select_compl n c). + destruct c0; simpl; eauto. simpl; eauto. + + simpl in TIC. inv TIC. + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. Lemma transl_blocks_distrib: forall c f bb tbb tc, @@ -1170,85 +1199,59 @@ Lemma transl_blocks_distrib: -> transl_block f bb = OK (tbb :: nil) /\ transl_blocks f c = OK tc. Proof. - intros. destruct bb as [hd bdy ex]. simpl in *. - monadInv H. monadInv EQ. simpl in *. - destruct ex. - - destruct c0. - + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + simpl in EQ. destruct s0; try discriminate. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + destruct TODO. (* TODO - requires Sylvain black magic *) - + simpl in EQ. monadInv EQ. simpl in *. inv H1. - unfold transl_block. simpl. rewrite EQ0. simpl. unfold gen_bblocks. simpl. auto. - + simpl in EQ. unfold transl_cbranch in EQ. destruct c0; destruct c. - all: try ( - repeat (destruct l; try discriminate); - monadInv EQ; simpl in *; inv H1; - unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; rewrite EQ; simpl; - unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( - simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; - rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate); monadInv EQ; destruct (Int.eq n Int.zero) eqn:EQ; ( - simpl in H1; inv H1; unfold transl_block; simpl; rewrite EQ0; simpl; rewrite EQ2; simpl; - rewrite EQ; simpl; unfold gen_bblocks; simpl; auto). - * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. - rewrite EQ2; simpl. unfold gen_bblocks; simpl. unfold transl_opt_compuimm in *. - destruct (select_comp n c0). destruct c; try (simpl; inv H1; auto). - unfold transl_comp in *. simpl. inv H1. auto. - * repeat (destruct l; try discriminate). monadInv EQ. unfold transl_block. simpl. rewrite EQ0; simpl. - rewrite EQ2; simpl. unfold gen_bblocks in *. simpl in *. unfold transl_opt_compuimm in *. - destruct (select_comp n c0). destruct c1; try (simpl; inv H1; auto). simpl in *. inv H1. auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; inv H1; auto. - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - destruct (Int64.eq n Int64.zero); simpl in *. - all: monadInv EQ; rewrite EQ2; simpl; unfold gen_bblocks in *; simpl in *; - unfold transl_opt_compluimm in *; - destruct (select_compl n c0) eqn:SEL; try (destruct c; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). - * repeat (destruct l; try discriminate). unfold transl_block. simpl; rewrite EQ0; simpl. - monadInv EQ. rewrite EQ2; simpl. unfold gen_bblocks in *; simpl in *. - unfold transl_opt_compluimm in *. destruct (select_compl n c0); try (destruct c1; simpl in *; inv H1; auto); try (simpl in *; inv H1; auto). - + simpl in EQ. discriminate. - + simpl in EQ. inv EQ. unfold transl_block. simpl; rewrite EQ0; simpl. unfold gen_bblocks in *. - simpl in *. inv H1; auto. - - monadInv EQ. simpl in H1. inv H1. unfold transl_block. simpl. rewrite EQ0. simpl. - unfold gen_bblocks. simpl. auto. + intros until tc. 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) -> gen_bblocks thd tbdy tex = tbb :: nil -> header tbb = thd - /\ body tbb = tbdy ++ (Pnop :: extract_basic tex) + /\ body tbb = tbdy ++ extract_basic tex /\ exit tbb = extract_ctl tex. Proof. - intros. unfold gen_bblocks in H. - destruct (extract_ctl tex). + intros until tbb. intros Hnonil GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. - destruct c. - + destruct i. inv H. - + inv H. auto. - - inv H. auto. + + destruct i. inv GENB. + + 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. +Axiom TODO: False. + Lemma transl_block_nobuiltin: forall f bb tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> transl_block f bb = OK (tbb :: nil) -> exists c c', transl_basic_code' f (MB.body bb) true = OK c /\ transl_instr_control f (MB.exit bb) true = OK c' - /\ body tbb = c ++ (Pnop :: extract_basic c') + /\ body tbb = c ++ extract_basic c' /\ exit tbb = extract_ctl c'. Proof. - intros. monadInv H. + intros until tbb. intros Hnonil TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + +(* monadInv H. eexists. eexists. split; eauto. split; eauto. - eapply gen_bblocks_nobuiltin. eauto. -Qed. + eapply gen_bblocks_nobuiltin. eauto. *) +Admitted. Lemma nextblock_preserves: forall rs rs' bb r, @@ -1281,7 +1284,7 @@ Proof. + (* MBcall *) exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. - intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. +(* intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. destruct tbb' as [hd' bdy' ex']; simpl in *. subst. destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1333,7 +1336,7 @@ Proof. 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. -Qed. + *)Admitted. (* Lemma transl_blocks_body: forall f bb c tbb tc @@ -1392,7 +1395,7 @@ Proof. destruct (extract_ctl x2). - destruct c0; destruct i; simpl; eauto. - simpl; eauto. -Qed. +Admitted. (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': -- cgit From 25facfb18832f58bfa2a7fff81b3c130b5869e77 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 16 Oct 2018 11:55:11 +0200 Subject: transl_blocks de nouveau prouvé + Ltac exploreInst MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 40 ++++++++++++++----- mppa_k1c/Asmblockgenproof.v | 93 +++++++++++++++++++++++++++++++++++---------- 2 files changed, 104 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ad5bbe97..eab29d0e 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -133,7 +133,7 @@ Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. -Definition select_comp (n: int) (c: comparison) : option comparison := +(* Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then match c with | Ceq => Some Ceq @@ -142,17 +142,28 @@ Definition select_comp (n: int) (c: comparison) : option comparison := end else None - . + . *) Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - match select_comp n c with + if Int.eq n Int.zero then + match c with + | Ceq => Pcbu BTweqz r1 lbl ::g k + | Cne => Pcbu BTwnez r1 lbl ::g k + | _ => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + end + else + 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 @@ -167,13 +178,24 @@ Definition select_compl (n: int64) (c: comparison) : option comparison := Definition transl_opt_compluimm (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - match select_compl n c with + if Int64.eq n Int64.zero then + match c with + | Ceq => Pcbu BTdeqz r1 lbl ::g k + | Cne => Pcbu BTdnez r1 lbl ::g k + | _ => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + end + else + loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + . + +(* match select_compl n c with | Some Ceq => Pcbu BTdeqz r1 lbl ::g k | Some Cne => Pcbu BTdnez r1 lbl ::g k | Some _ => nil (* Never happens *) | None => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) end . + *) Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := @@ -810,15 +832,15 @@ Definition it1_is_parent (before: bool) (i: Machblock.basic_inst) : bool := (** This is the naive definition that we no longer use because it is not tail-recursive. It is kept as specification. *) -Fixpoint transl_basic (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := +Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := match il with | nil => OK nil | i1 :: il' => - do k <- transl_basic f il' (it1_is_parent it1p i1); + do k <- transl_basic_code f il' (it1_is_parent it1p i1); transl_instr_basic f i1 it1p k end. -(** This is an equivalent definition in continuation-passing style +(* (** This is an equivalent definition in continuation-passing style that runs in constant stack space. *) Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) @@ -831,7 +853,7 @@ Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst end. Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := - transl_basic_rec f il it1p (fun c => OK c). + 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, @@ -868,7 +890,7 @@ Qed. (* Next Obligation. Qed. *) Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := - do c <- transl_basic_code' f fb.(Machblock.body) true; + do c <- transl_basic_code f fb.(Machblock.body) true; do ctl <- transl_instr_control f fb.(Machblock.exit) true; OK (gen_bblocks fb.(Machblock.header) c ctl) . diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index fba22da4..8667dc2e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1162,6 +1162,16 @@ Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. Qed. +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 + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + Lemma no_builtin_preserved: forall f ex x2, (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> @@ -1172,21 +1182,14 @@ Proof. intros until x2. intros Hbuiltin TIC. destruct ex. - destruct c. - + simpl in TIC. destruct s0; try inversion TIC. simpl. eauto. - + simpl in TIC. destruct s0; try inversion TIC. simpl. eauto. + + simpl in TIC. exploreInst; simpl; eauto. + + simpl in TIC. exploreInst; simpl; eauto. + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). apply Hbuiltin. contradict H; auto. - + simpl in TIC. monadInv TIC. simpl. eauto. - + simpl in TIC. unfold transl_cbranch in TIC. destruct c. - all: try ( destruct l; try (inv TIC; fail); destruct l; try (inv TIC; fail); destruct l; monadInv TIC; - simpl; eauto; try inv TIC). - * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. destruct (Int.eq n Int.zero); simpl; eauto. - * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. unfold transl_opt_compuimm. destruct (select_comp n c). - destruct c0; simpl; eauto. - simpl; eauto. - * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. destruct (Int64.eq n Int64.zero); simpl; eauto. - * repeat (destruct l; try (inv TIC; fail)). monadInv TIC. unfold transl_opt_compluimm. destruct (select_compl n c). - destruct c0; simpl; eauto. simpl; eauto. + + simpl in TIC. exploreInst; simpl; eauto. + + 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. + simpl in TIC. inv TIC. + simpl in TIC. monadInv TIC. simpl. eauto. - monadInv TIC. simpl; auto. @@ -1233,25 +1236,73 @@ Proof. + contradict H; simpl; auto. Qed. -Axiom TODO: False. +Lemma transl_instr_basic_nonil: + forall k f bi b x, + transl_instr_basic f bi b 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. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: unfold transl_memory_access in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: unfold transl_memory_access in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x b, + bdy <> nil -> + transl_basic_code f bdy b = 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 true = 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. + - contradict Hnonil; auto. +Qed. Lemma transl_block_nobuiltin: forall f bb tbb, (MB.body bb <> nil \/ MB.exit bb <> None) -> transl_block f bb = OK (tbb :: nil) -> exists c c', - transl_basic_code' f (MB.body bb) true = OK c + transl_basic_code f (MB.body bb) true = OK c /\ transl_instr_control f (MB.exit bb) true = OK c' /\ body tbb = c ++ extract_basic c' /\ exit tbb = extract_ctl c'. Proof. intros until tbb. intros Hnonil TLB. monadInv TLB. destruct Hnonil. - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - -(* monadInv H. - eexists. eexists. split; eauto. split; eauto. - eapply gen_bblocks_nobuiltin. eauto. *) -Admitted. + left. eapply transl_basic_code_nonil; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. +Qed. Lemma nextblock_preserves: forall rs rs' bb r, @@ -1264,6 +1315,8 @@ Proof. - subst. Simpl. Qed. +Axiom TODO: False. + Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 cs2, MB.body bb' = nil -> -- cgit From b2c56f0cc78e4814fc1423c5836986c9882a9c1b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 16 Oct 2018 15:11:42 +0200 Subject: step_simulation_bblock' is back online, using exec_body instead of exec_straight --- mppa_k1c/Asmblockgenproof.v | 93 ++++++++++++++++++++++++++++++++++++--------- 1 file changed, 74 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 8667dc2e..28c0f3c6 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1315,7 +1315,7 @@ Proof. - subst. Simpl. Qed. -Axiom TODO: False. +Axiom TODO: False. Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 cs2, @@ -1327,17 +1327,18 @@ Theorem step_simu_control: match_asmblock fb cs2 (Asmblock.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_straight tge (body tbb') rs2 m2 nil rs3 m3 + exec_body tge (body tbb') rs2 m2 = Next rs3 m3 /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 /\ match_states S'' (State rs4 m4)). Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. +(* intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. - inv MCS. inv MAS. destruct ctl. + (* MBcall *) exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. -(* intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. + right. rewrite <- H. discriminate. + intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. destruct tbb' as [hd' bdy' ex']; simpl in *. subst. destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1355,7 +1356,7 @@ Proof. econstructor; eauto. assert (f1 = f) by congruence. subst f1. exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. econstructor; eauto. econstructor; eauto. + repeat eexists. simpl. econstructor; eauto. econstructor; eauto. remember (nextblock _ _) as rs'1. econstructor; eauto. econstructor; eauto. eapply agree_sp_def; eauto. @@ -1388,8 +1389,8 @@ Proof. 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. - *)Admitted. + eapply agree_exten; eauto. intros. Simpl. *) +Admitted. (* Lemma transl_blocks_body: forall f bb c tbb tc @@ -1411,7 +1412,7 @@ Qed. Definition mb_remove_first (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. -Theorem step_simu_body': +(* Theorem step_simu_body': forall s fb sp bb c ms m rs1 m1 tbb tc ms' m' bi bdy, MB.body bb = bi :: bdy -> basic_step ge s fb sp ms m bi ms' m' -> @@ -1422,18 +1423,18 @@ Theorem step_simu_body': (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) /\ exit tbb' = exit tbb. Proof. -Admitted. +Admitted. *) Theorem step_simu_body: forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', body_step ge s fb sp (MB.body bb) ms m ms' m' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - (mb_remove_body bb = bb \/ - (exists rs2 m2 tbb', - (exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 + (exists rs2 m2 tbb' l, + body tbb = l ++ body tbb' + /\ exec_body tge l rs1 m1 = Next rs2 m2 /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) - /\ exit tbb' = exit tbb ))). + /\ exit tbb' = exit tbb ). Proof. intros until m'. intros BSTEP MCS. inv BSTEP. @@ -1450,6 +1451,60 @@ Proof. - simpl; eauto. Admitted. +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_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. + +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. + (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': forall sf f sp bb bb' rs m rs' m' s'' c S1, @@ -1466,22 +1521,22 @@ Proof. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. exploit match_state_codestate; eauto. intros (S1' & MCS & MAS & cseq). subst. - exploit step_simu_body; eauto. intro STSIMUBODY. inv STSIMUBODY. - - (* mb_remove_body bb = bb *) destruct TODO. - - destruct H4 as (rs2 & m2 & tbb' & EXES & MCS' & Hexit). + exploit step_simu_body; eauto. intros (rs2 & m2 & tbb' & l & Hbody & EXES & MCS' & Hexit). remember (mb_remove_body bb) as bb'. assert (MB.body bb' = nil). subst. destruct bb as [hd bdy ex]; simpl; auto. exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. exploit step_simu_control; eauto. - econstructor; eauto. erewrite exec_straight_pc; eauto. + econstructor; eauto. + + erewrite exec_body_pc; eauto. assert (x = tf) by congruence. subst x. eauto. intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). - exploit exec_straight_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. + exploit exec_body_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. rewrite Hexit in EXECR. - exploit (exec_straight_bblock); eauto. intro EXECB. inv EXECB. + exploit (exec_body_control); eauto. rewrite Hbody. eauto. intro EXECB. inv EXECB. exists (State rs4 m4). split; auto. eapply plus_one. eapply exec_step_internal; eauto. -- cgit From b633b56cbffa97972c650ba82d624e411e26a3be Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 16 Oct 2018 15:39:26 +0200 Subject: step_simu_control with MBcall and exit=None are back online --- mppa_k1c/Asmblockgenproof.v | 53 ++++++++------------------------------------- 1 file changed, 9 insertions(+), 44 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 28c0f3c6..1143cf7e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1331,7 +1331,7 @@ Theorem step_simu_control: /\ exec_control_rel tge fn (exit tbb') tbb rs3 m3 rs4 m4 /\ match_states S'' (State rs4 m4)). Proof. -(* intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. + intros until cs2. intros Hbody Hbuiltin FIND Hcodestate MCS MAS ESTEP. inv ESTEP. - inv MCS. inv MAS. destruct ctl. + (* MBcall *) @@ -1356,12 +1356,8 @@ Proof. econstructor; eauto. assert (f1 = f) by congruence. subst f1. exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. simpl. econstructor; eauto. econstructor; eauto. - remember (nextblock _ _) as rs'1. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - exploit nextblock_preserves. eapply Heqrs'1. eauto. auto. + repeat eexists. econstructor; eauto. econstructor; eauto. + eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H12. eauto. Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + (* MBtailcall *) @@ -1379,52 +1375,21 @@ Proof. destruct TODO. - inv MCS. inv MAS. exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. - intros (c0 & c' & TBB & TCT & BEQ & EXEQ). - destruct bb' as [hd' bdy' ex']; simpl in *. subst. inv TBB. inv TCT. simpl in *. - repeat eexists. rewrite BEQ. econstructor; eauto. econstructor; eauto. - rewrite EXEQ. econstructor; eauto. econstructor; eauto. - unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. + 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. + simpl. repeat eexists. + econstructor; eauto. unfold nextblock. 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. *) -Admitted. - -(* Lemma transl_blocks_body: - forall f bb c tbb tc - transl_blocks f (bb::c) = OK (tbb::tc) -> - - exists tbdy tbdy', - transl_basic_code' f (MB.body bb) true = OK (tbdy) - /\ transl_basic_code' f (MB.body (mb_remove_body bb)) true = OK (tbdy') - /\ body tbb = Pnop :: tbdy ++ tbdy'. -Proof. - intros. monadInv TBLS. monadInv EQ. exists x1. - unfold gen_bblocks in H0. destruct (extract_ctl x2). destruct c0. destruct i. - - inv H0. simpl. exists nil. rewrite app_nil_r. auto. - - inv H0. simpl. eexists. eauto. - - inv H0. simpl. eexists. eauto. + eapply agree_exten; eauto. intros. Simpl. Qed. - *) Definition mb_remove_first (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. -(* Theorem step_simu_body': - forall s fb sp bb c ms m rs1 m1 tbb tc ms' m' bi bdy, - MB.body bb = bi :: bdy -> - basic_step ge s fb sp ms m bi ms' m' -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - exists rs2 m2 tbb', - exec_straight tge (body tbb) rs1 m1 (body tbb') rs2 m2 - /\ match_codestate fb (MB.State s fb sp (mb_remove_first bb :: c) ms' m') - (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) - /\ exit tbb' = exit tbb. -Proof. -Admitted. *) - Theorem step_simu_body: forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', body_step ge s fb sp (MB.body bb) ms m ms' m' -> -- cgit From 7048a1fe04f45695aa6f7c4a35a6f9dcb5456c2b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 16 Oct 2018 17:41:14 +0200 Subject: Squelette du step_simu_basic --- mppa_k1c/Asmblockgenproof.v | 86 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 66 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1143cf7e..2a412e98 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1390,8 +1390,65 @@ 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 step_simu_basic: + forall bb bb' s fb sp tbb c ms m rs1 m1 tc ms' m' bi bdy, + MB.body bb = bi::(bdy) -> + bb' = {| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> + (exists rs2 m2 tbb' l, + body tbb = l ++ body tbb' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') + (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) + /\ exit tbb' = exit tbb). +Proof. +Admitted. + +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. + +Lemma step_simu_body': + forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> + (exists rs2 m2 tbb' l, + body tbb = l ++ body tbb' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') + (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) + /\ exit tbb' = exit tbb ). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros BSTEP MCS. inv BSTEP. + exists rs1, m1, tbb, nil. + repeat (split; simpl; auto). + - intros until m'. intros BSTEP 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. + intros (rs2 & m2 & tbb' & l & Hbody & EBODY & MCS' & Hexit). + simpl in *. + exploit IHbdy. eapply H6. eauto. + intros (rs3 & m3 & tbb'' & l' & Hbody' & EBODY' & MCS'' & Hexit'). + exists rs3, m3, tbb'', (l++l'). + repeat (split; simpl; auto). + rewrite Hbody. rewrite Hbody'. rewrite app_assoc. auto. + eapply exec_body_trans; eauto. + congruence. +Qed. + Theorem step_simu_body: - forall s fb sp bb c ms m rs1 m1 tbb tc ms' m', + forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', body_step ge s fb sp (MB.body bb) ms m ms' m' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> (exists rs2 m2 tbb' l, @@ -1401,20 +1458,22 @@ Theorem step_simu_body: (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) /\ exit tbb' = exit tbb ). Proof. - intros until m'. intros BSTEP MCS. inv BSTEP. - -Admitted. + intros. exploit step_simu_body'; eauto. + intros (rs2 & m2 & tbb' & l & Hbody & EXEB & MCS & Hexit). + exists rs2, m2, tbb', l. repeat (split; simpl; auto). + inv MCS. econstructor; eauto. +Qed. Lemma transl_blocks_nonil: forall f bb c tc, transl_blocks f (bb::c) = OK tc -> exists tbb tc', tc = tbb :: tc'. Proof. - intros. monadInv H. monadInv EQ. unfold gen_bblocks. + intros until tc. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. destruct (extract_ctl x2). - destruct c0; destruct i; simpl; eauto. - - simpl; eauto. -Admitted. + - destruct x1; simpl; eauto. +Qed. Lemma exec_body_straight: forall l rs0 m0 rs1 m1, @@ -1446,19 +1505,6 @@ Proof. erewrite exec_basic_instr_pc; eauto. 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. - Lemma exec_body_control: forall b rs1 m1 rs2 m2 rs3 m3 fn, exec_body tge (body b) rs1 m1 = Next rs2 m2 -> -- cgit From d6ac402cfec2443ecb1a73a92838701236889afe Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Oct 2018 17:09:17 +0200 Subject: Avancement dans le cas MBgetstack du step_simu_basic --- mppa_k1c/Asmblockgenproof.v | 64 +++++++++++++++++++++++++++++++++++++++----- mppa_k1c/Asmblockgenproof1.v | 11 ++++---- 2 files changed, 64 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 2a412e98..ec5f2f3e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1390,9 +1390,23 @@ 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' rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + exists l, + c = l ++ c' + /\ exec_body tge l rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros. inv H. + - exists (a ::i nil). split; auto. simpl. rewrite H7. auto. + - apply IHc in H8. destruct H8 as (l & Hc & EXECB). subst. + exists (a ::i l). split; auto. simpl. rewrite H2. auto. +Qed. + Lemma step_simu_basic: forall bb bb' s fb sp tbb c ms m rs1 m1 tc ms' m' bi bdy, - MB.body bb = bi::(bdy) -> + MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> bb' = {| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |} -> basic_step ge s fb sp ms m bi ms' m' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> @@ -1403,7 +1417,41 @@ Lemma step_simu_basic: (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) /\ exit tbb' = exit tbb). Proof. -Admitted. +(* intros until bdy. intros Hbody Hnobuiltin Hbb' BSE MCS. inv MCS. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). + exploit transl_block_nobuiltin; eauto. left; rewrite Hbody; discriminate. + intros (lbi & le & TBC & TIC & Htbody & Htexit). + rewrite Hbody in TBC. monadInv TBC. + inv BSE. + - (* 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. { destruct TODO. } + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. destruct EXECS as (l & Hlbi & EXECB). + exists rs2 m1 (* something *) l. +(* TODO *) + + + left; eapply exec_straight_steps; eauto. intros. simpl in TR. + exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. + exists rs'; split. eauto. + split. eapply agree_set_mreg; eauto with asmgen. congruence. + simpl; congruence. + - (* MBsetstack *) + destruct TODO. + - (* MBgetparam *) + destruct TODO. + - (* MBop *) + destruct TODO. + - (* MBload *) + destruct TODO. + - (* MBstore *) + destruct TODO. + *)Admitted. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, @@ -1420,6 +1468,7 @@ Qed. Lemma step_simu_body': forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', + (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' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> (exists rs2 m2 tbb' l, @@ -1430,15 +1479,15 @@ Lemma step_simu_body': /\ exit tbb' = exit tbb ). Proof. intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros BSTEP MCS. inv BSTEP. + - intros until m'. intros Hnobuiltin BSTEP MCS. inv BSTEP. exists rs1, m1, tbb, nil. repeat (split; simpl; auto). - - intros until m'. intros BSTEP MCS. inv BSTEP. + - intros until m'. intros Hnobuiltin BSTEP 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. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. intros (rs2 & m2 & tbb' & l & Hbody & EBODY & MCS' & Hexit). simpl in *. - exploit IHbdy. eapply H6. eauto. + exploit IHbdy; simpl; auto. eapply H6. eauto. intros (rs3 & m3 & tbb'' & l' & Hbody' & EBODY' & MCS'' & Hexit'). exists rs3, m3, tbb'', (l++l'). repeat (split; simpl; auto). @@ -1449,6 +1498,7 @@ Qed. Theorem step_simu_body: forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', + (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' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> (exists rs2 m2 tbb' l, @@ -1532,6 +1582,8 @@ Proof. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. exploit match_state_codestate; eauto. intros (S1' & MCS & MAS & cseq). subst. + assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). + intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. exploit step_simu_body; eauto. intros (rs2 & m2 & tbb' & l & Hbody & EXES & MCS' & Hexit). remember (mb_remove_body bb) as bb'. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 81123c9b..08be374a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1324,18 +1324,18 @@ Proof. Qed. -(* + Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR31 -> exists rs', - exec_straight ge fn c rs m k rs' m + exec_straight ge c rs m k rs' m /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until v; intros TR LOAD NOT31. +Proof. Admitted. +(* intros until v; intros TR LOAD NOT31. assert (A: exists mk_instr, c = indexed_memory_access mk_instr base ofs k /\ forall base' ofs' rs', @@ -1345,8 +1345,9 @@ Proof. destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } destruct A as (mk_instr & B & C). subst c. eapply indexed_load_access_correct; eauto with asmgen. -Qed. +Qed. *) +(* Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> -- cgit From bd72e78a087b39e036176e1f05348ff0c797324d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 19 Oct 2018 17:28:15 +0200 Subject: Commencé à réintroduire du "ep" qui a du sens MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 16 ++--- mppa_k1c/Asmblockgenproof.v | 141 +++++++++++++++++++++++++++---------------- mppa_k1c/Asmblockgenproof0.v | 33 +++++----- mppa_k1c/Asmgen.v | 2 +- 4 files changed, 114 insertions(+), 78 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index eab29d0e..a4c94e9b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -781,7 +781,7 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) end. Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst) - (ep: bool) : res code := + : res code := match oi with | None => OK nil | Some i => @@ -889,18 +889,18 @@ Qed. (* Next Obligation. intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. Qed. *) -Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) : res (list bblock) := - do c <- transl_basic_code f fb.(Machblock.body) true; - do ctl <- transl_instr_control f fb.(Machblock.exit) true; +Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := + do c <- transl_basic_code f fb.(Machblock.body) ep; + do ctl <- transl_instr_control f fb.(Machblock.exit); OK (gen_bblocks fb.(Machblock.header) c ctl) . -Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) := +Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := match lmb with | nil => OK nil | mb :: lmb => - do lb <- transl_block f mb; - do lb' <- transl_blocks f lmb; + do lb <- transl_block f mb ep; + do lb' <- transl_blocks f lmb false; OK (lb ++ lb') end . @@ -908,7 +908,7 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) := Definition transl_function (f: Machblock.function) := - do lb <- transl_blocks f f.(Machblock.fn_code); + do lb <- transl_blocks f f.(Machblock.fn_code) true; OK (mkfunction f.(Machblock.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b Pget GPR8 RA ::b diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ec5f2f3e..61a2c460 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -495,10 +495,12 @@ Lemma return_address_exists: exists ra, return_address_offset f c ra. Proof. intros. eapply Asmblockgenproof0.return_address_exists; eauto. - - intros f0 tf H0. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - monadInv EQ. simpl. - eapply ex_intro; constructor 1; eauto with coqlib. + +- 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. @@ -1076,7 +1078,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (STACKS: match_stack ge s) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (MEXT: Mem.extends m m') - (TRANS: transl_blocks f (bb::c) = OK (tbb::tc)) + (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) (AG: agree ms sp rs) (DXP: ep = true -> rs#FP = parent_sp s), match_codestate fb (Machblock.State s fb sp (bb::c) ms m) @@ -1125,24 +1127,37 @@ Proof. - discriminate. Qed. *) +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. +Qed. + Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m rs m' tbb tc tf ep f, + forall mbs abs s fb sp bb c ms m rs m' (* tbb tc *) (* tf *) (* ep *) f, mbs = (Machblock.State s fb sp (bb::c) ms m) -> abs = (Asmblock.State rs m') -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_blocks f (bb::c) = OK (tbb::tc) -> - transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> +(* transl_blocks f (bb::c) ep = OK (tbb::tc) -> *) +(* transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> *) match_states mbs abs -> - exists cs, (match_codestate fb mbs cs /\ match_asmblock fb cs abs - /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). + exists cs tbb tc, + ( match_codestate fb mbs cs /\ match_asmblock fb cs abs + /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). Proof. - intros. inv H4; try discriminate. - inv H6. inv H5. rewrite FIND in H1. inv H1. - esplit. repeat split. - econstructor. 4: eapply H2. all: eauto. (* inv H3. eapply H1. *) - inv AT. + intros until f. intros Hmbs Habs Hfind MS. + subst. inv MS. assert (f = f0) by congruence; subst f0. clear FIND. inv AT. + exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). + rename tc into tc''. rename tc' into tc. rename tc'' into tc'. subst tc'. + esplit. + exists tbb, tc. + repeat split. econstructor. 4: eapply H2. all: eauto. econstructor; eauto. - congruence. Qed. (* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. @@ -1175,7 +1190,7 @@ Ltac exploreInst := Lemma no_builtin_preserved: forall f ex x2, (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex true = OK x2 -> + transl_instr_control f ex = OK x2 -> (exists i, extract_ctl x2 = Some (PCtlFlow i)) \/ extract_ctl x2 = None. Proof. @@ -1196,13 +1211,13 @@ Proof. Qed. Lemma transl_blocks_distrib: - forall c f bb tbb tc, - transl_blocks f (bb::c) = OK (tbb::tc) + 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 = OK (tbb :: nil) - /\ transl_blocks f c = OK tc. + -> transl_block f bb ep = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. Proof. - intros until tc. intros TLBS Hbuiltin. + 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. @@ -1237,8 +1252,8 @@ Proof. Qed. Lemma transl_instr_basic_nonil: - forall k f bi b x, - transl_instr_basic f bi b k = OK x -> + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> x <> nil. Proof. intros until x. intros TIB. @@ -1255,9 +1270,9 @@ Proof. Qed. Lemma transl_basic_code_nonil: - forall bdy f x b, + forall bdy f x ep, bdy <> nil -> - transl_basic_code f bdy b = OK x -> + transl_basic_code f bdy ep = OK x -> x <> nil. Proof. induction bdy as [|bi bdy]. @@ -1274,7 +1289,7 @@ Qed. Lemma transl_instr_control_nonil: forall ex f x, ex <> None -> - transl_instr_control f ex true = OK x -> + transl_instr_control f ex = OK x -> extract_ctl x <> None. Proof. intros ex f x Hnonil TIC. @@ -1288,12 +1303,12 @@ Proof. Qed. Lemma transl_block_nobuiltin: - forall f bb tbb, + forall f bb ep tbb, (MB.body bb <> nil \/ MB.exit bb <> None) -> - transl_block f bb = OK (tbb :: nil) -> + transl_block f bb ep = OK (tbb :: nil) -> exists c c', - transl_basic_code f (MB.body bb) true = OK c - /\ transl_instr_control f (MB.exit bb) true = OK 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. @@ -1379,12 +1394,13 @@ Proof. 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. simpl. repeat eexists. - econstructor; eauto. unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. + econstructor. 4: instantiate (3 := false). all:eauto. unfold nextblock. 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) := @@ -1404,9 +1420,23 @@ Proof. exists (a ::i l). split; auto. simpl. rewrite H2. auto. Qed. +Lemma transl_blocks_basic_step: + forall bb tbb c tc bi bdy x le f tbb' ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) -> + MB.body bb = bi::(bdy) -> (bdy <> nil \/ MB.exit bb <> None) -> + transl_basic_code f bdy (it1_is_parent true bi) = OK x -> + transl_instr_control f (MB.exit bb) = OK le -> + header tbb' = header tbb -> body tbb' = x ++ extract_basic le -> exit tbb' = exit tbb -> + transl_blocks f ({| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |}::c) + (it1_is_parent ep bi) = + OK (tbb'::tc). +Proof. +Admitted. + Lemma step_simu_basic: forall bb bb' s fb sp tbb c ms m rs1 m1 tc ms' m' bi bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (bdy <> nil \/ MB.exit bb <> None) -> bb' = {| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |} -> basic_step ge s fb sp ms m bi ms' m' -> match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> @@ -1417,12 +1447,22 @@ Lemma step_simu_basic: (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) /\ exit tbb' = exit tbb). Proof. -(* intros until bdy. intros Hbody Hnobuiltin Hbb' BSE MCS. inv MCS. +Admitted. +(* intros until bdy. intros Hbody Hnobuiltin Hnotempty Hbb' BSE MCS. inv MCS. exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. left; rewrite Hbody; discriminate. intros (lbi & le & TBC & TIC & Htbody & Htexit). rewrite Hbody in TBC. monadInv TBC. - inv BSE. + assert (Hcorrect: wf_bblock (header tbb) (x ++ extract_basic le) (exit tbb)). { + unfold wf_bblock. unfold non_empty_bblock. + inv Hnotempty. + - assert (x <> nil). eapply transl_basic_code_nonil; eauto. left. destruct x; try discriminate. + contradict H0; simpl; auto. + - right. rewrite Htexit. eapply transl_instr_control_nonil; eauto. + } +(* remember {| header := header tbb; body := x ++ extract_basic le; exit := exit tbb; correct := Hcorrect |} + as tbb'. + *) inv BSE. - (* MBgetstack *) simpl in EQ0. @@ -1432,7 +1472,13 @@ Proof. exploit loadind_correct; eauto with asmgen. { destruct TODO. } intros (rs2 & EXECS & Hrs'1 & Hrs'2). eapply exec_straight_body in EXECS. destruct EXECS as (l & Hlbi & EXECB). - exists rs2 m1 (* something *) l. + remember {| header := header tbb; body := x ++ extract_basic le; exit := exit tbb; correct := Hcorrect |} + as tbb'. + exists rs2, m1, tbb', l. subst. + repeat (split; simpl; auto). rewrite Htbody. apply app_assoc_reverse. + econstructor; eauto. eapply transl_blocks_basic_step; eauto. + eapply agree_set_mreg; eauto with asmgen. + instantiate (1 := ep). intro Hep. rewrite <- DXP; auto. apply Hrs'2; try discriminate. (* TODO *) @@ -1451,7 +1497,7 @@ Proof. destruct TODO. - (* MBstore *) destruct TODO. - *)Admitted. +Admitted. *) Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, @@ -1478,7 +1524,8 @@ Lemma step_simu_body': (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) /\ exit tbb' = exit tbb ). Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. +Admitted. +(* intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - intros until m'. intros Hnobuiltin BSTEP MCS. inv BSTEP. exists rs1, m1, tbb, nil. repeat (split; simpl; auto). @@ -1494,7 +1541,7 @@ Proof. rewrite Hbody. rewrite Hbody'. rewrite app_assoc. auto. eapply exec_body_trans; eauto. congruence. -Qed. +Qed. *) Theorem step_simu_body: forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', @@ -1514,17 +1561,6 @@ Proof. inv MCS. econstructor; eauto. Qed. -Lemma transl_blocks_nonil: - forall f bb c tc, - transl_blocks f (bb::c) = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. - intros until tc. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - Lemma exec_body_straight: forall l rs0 m0 rs1 m1, l <> nil -> @@ -1576,7 +1612,8 @@ Lemma step_simulation_bblock': 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 BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. +Admitted. +(* intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. remember (Machblock.State sf f sp (bb::c) rs m) as mbs. remember (State rs0 m'0) as abs. inversion AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. @@ -1604,7 +1641,7 @@ Proof. split; auto. eapply plus_one. eapply exec_step_internal; eauto. assert (x = tf) by congruence. subst x. eapply find_bblock_tail; eauto. -Qed. +Qed. *) Lemma step_simulation_bblock: forall sf f sp bb ms m ms' m' S2 c, @@ -1748,8 +1785,6 @@ Local Transparent destroyed_at_function_entry. right. split. omega. split. auto. rewrite <- ATPC in H5. econstructor; eauto. congruence. -Unshelve. - exact true. Qed. Lemma transf_initial_states: diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 5c2d6f02..4074c4d6 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -483,7 +483,7 @@ Qed. Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := forall tf tc, transf_function f = OK tf -> - transl_blocks f c = OK tc -> + transl_blocks f c false = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. (* NB: these two lemma should go into [Coqlib.v] *) @@ -503,14 +503,14 @@ Hint Resolve is_tail_app_inv: coqlib. Lemma transl_blocks_tail: forall f c1 c2, is_tail c1 c2 -> - forall tc2, transl_blocks f c2 = OK tc2 -> - exists tc1, transl_blocks f c1 = OK tc1 /\ is_tail tc1 tc2. + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. Proof. induction 1; simpl; intros. - exists tc2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & A & B). - exists tc1; split. auto. - eapply is_tail_trans; eauto with coqlib. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. Qed. Lemma is_tail_code_tail: @@ -524,7 +524,7 @@ Section RETADDR_EXISTS. Hypothesis transf_function_inv: forall f tf, transf_function f = OK tf -> - exists tc, transl_blocks f (Machblock.fn_code f) = OK tc /\ is_tail tc (fn_blocks tf). + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). Hypothesis transf_function_len: forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. @@ -536,15 +536,16 @@ Lemma return_address_exists: 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 & TR1 & TL1). - exploit transl_blocks_tail; eauto. intros (tc2 & TR2 & TL2). - unfold return_address_offset. + + 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; eauto with coqlib. } - exploit is_tail_code_tail; eauto. - intros [ofs CT]. - exists (Ptrofs.repr ofs). intros. + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. rewrite Ptrofs.unsigned_repr. congruence. exploit code_tail_bounds; eauto. intros; apply transf_function_len in TF. omega. @@ -564,7 +565,7 @@ Inductive transl_code_at_pc (ge: MB.genv): forall b ofs f c ep tf tc, Genv.find_funct_ptr ge b = Some(Internal f) -> transf_function f = Errors.OK tf -> - transl_blocks f c = OK tc -> + transl_blocks f c ep = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 8c3d1e8c..9b9e6272 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -39,5 +39,5 @@ Definition transf_function (f: Mach.function) : res Asm.function := Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) := let mbf := Machblockgen.transf_function f in let mbc := Machblockgen.trans_code l in - do abc <- transl_blocks mbf mbc; + do abc <- transl_blocks mbf mbc true; OK (unfold abc). \ No newline at end of file -- cgit From 7278f5195f03a024187e4517eda17cf672968e1e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 22 Oct 2018 18:09:15 +0200 Subject: New definition of Codestate, new match --- mppa_k1c/Asmblockgenproof.v | 203 +++++++++++++++++++++++--------------------- 1 file changed, 105 insertions(+), 98 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 61a2c460..6a9e5661 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1069,64 +1069,67 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := match_states (Machblock.Returnstate s ms m) (Asmblock.State rs m'). -Inductive codestate: Type := - | Codestate: state -> list AB.bblock -> option bblock -> codestate. +Record codestate := + mk_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 m' rs f tc ep c bb tbb tbb' + 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 m') - (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), + (MEXT: Mem.extends m m0) + (TRANSBODY: transl_basic_code f (MB.body bb) ep = OK tbc) + (TRANSCTL: transl_instr_control f (MB.exit bb) = OK tbi) + (TRANSC: transl_blocks f c false = OK tc) +(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) + (AG: agree ms sp rs0) + (DXP: ep = true -> rs0#FP = parent_sp s), match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) -(* | match_codestate_call: - forall s ms m m' rs tc - (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_codestate fb (Machblock.Callstate s fb ms m) - (Codestate (Asmblock.State rs m') tc None) - | match_codestate_return: - forall s ms m m' rs tc - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_codestate fb (Machblock.Returnstate s ms m) - (Codestate (Asmblock.State rs m') tc None) *). + {| pstate := (Asmblock.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; + pbody2 := (extract_basic tbi); + pctl := extract_ctl tbi; + fpok := ep; + rem := tc; + cur := Some tbb + |} + (* (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) *) +. Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := | match_asmblock_some: - forall rs f tf tc m tbb tbb' ofs + 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_asmblock fb (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) (Asmblock.State rs m) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + (GEN: gen_bblocks lhd tbdy tex = tbb::nil) + (HEADEROK: header tbb = lhd) + (BODYOK: body tbb = tbdy ++ extract_basic(tex)) + , + match_asmblock fb + {| pstate := (Asmblock.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; + fpok := ep; + rem := tc; + cur := Some tbb |} +(* (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) *) + (Asmblock.State rs m) . -(* Theorem match_codestate_state: - forall mbs abs fb cs rs m tbb tc, - cs = Codestate (Asmblock.State rs m) (tbb::tc) (Some tbb) -> - match_codestate fb mbs cs -> - match_asmblock fb cs abs -> - match_states mbs abs. -Proof. - intros until tc. intros ? MCS MAB. - inv MCS; inv MAB. inv H1. - - rewrite FIND0 in FIND. inv FIND. -(* rewrite FIND0 in FIND. inv FIND. *) - econstructor; eauto. rewrite PCeq. (* inv AT. *) econstructor; eauto. - - discriminate. - - discriminate. -Qed. *) - Lemma transl_blocks_nonil: forall f bb c tc ep, transl_blocks f (bb::c) ep = OK tc -> @@ -1138,45 +1141,6 @@ Proof. - destruct x1; simpl; eauto. Qed. -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m rs m' (* tbb tc *) (* tf *) (* ep *) f, - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - abs = (Asmblock.State rs m') -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> -(* transl_blocks f (bb::c) ep = OK (tbb::tc) -> *) -(* transl_code_at_pc ge (rs PC) fb f (bb::c) ep tf (tbb::tc) -> *) - match_states mbs abs -> - exists cs tbb tc, - ( match_codestate fb mbs cs /\ match_asmblock fb cs abs - /\ cs = (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb))). -Proof. - intros until f. intros Hmbs Habs Hfind MS. - subst. inv MS. assert (f = f0) by congruence; subst f0. clear FIND. inv AT. - exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). - rename tc into tc''. rename tc' into tc. rename tc'' into tc'. subst tc'. - esplit. - exists tbb, tc. - repeat split. econstructor. 4: eapply H2. all: eauto. - econstructor; eauto. -Qed. - -(* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. -Next Obligation. - unfold wf_bblock. unfold non_empty_bblock. left; discriminate. -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::nil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - Ltac exploreInst := repeat match goal with | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var @@ -1302,6 +1266,47 @@ Proof. - contradict Hnonil; auto. 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, + match_codestate fb mbs cs /\ match_asmblock fb 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. } + 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. + split; econstructor; eauto. +Qed. + +(* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. +Next Obligation. + unfold wf_bblock. unfold non_empty_bblock. left; discriminate. +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::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) -> @@ -1332,7 +1337,8 @@ Qed. Axiom TODO: False. -Theorem step_simu_control: +(* TODO - rewrite it with the new Codestate *) +(* Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 cs2, MB.body bb' = nil -> (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> @@ -1402,7 +1408,7 @@ Proof. 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 |}. @@ -1433,7 +1439,8 @@ Lemma transl_blocks_basic_step: Proof. Admitted. -Lemma step_simu_basic: +(* TODO - rewrite it with the new Codestate *) +(* Lemma step_simu_basic: forall bb bb' s fb sp tbb c ms m rs1 m1 tc ms' m' bi bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> (bdy <> nil \/ MB.exit bb <> None) -> @@ -1447,8 +1454,7 @@ Lemma step_simu_basic: (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) /\ exit tbb' = exit tbb). Proof. -Admitted. -(* intros until bdy. intros Hbody Hnobuiltin Hnotempty Hbb' BSE MCS. inv MCS. + intros until bdy. intros Hbody Hnobuiltin Hnotempty Hbb' BSE MCS. inv MCS. exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. left; rewrite Hbody; discriminate. intros (lbi & le & TBC & TIC & Htbody & Htexit). @@ -1464,7 +1470,8 @@ Admitted. as tbb'. *) inv BSE. - (* MBgetstack *) - simpl in EQ0. + destruct TODO. +(* simpl in EQ0. unfold Mach.load_stack in H. exploit Mem.loadv_extends; eauto. intros [v' [A B]]. @@ -1487,7 +1494,7 @@ Admitted. exists rs'; split. eauto. split. eapply agree_set_mreg; eauto with asmgen. congruence. simpl; congruence. - - (* MBsetstack *) + *) - (* MBsetstack *) destruct TODO. - (* MBgetparam *) destruct TODO. @@ -1497,7 +1504,7 @@ Admitted. destruct TODO. - (* MBstore *) destruct TODO. -Admitted. *) +Qed. *) Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, @@ -1512,7 +1519,8 @@ Proof. simpl. rewrite EBI. eapply IHl; eauto. Qed. -Lemma step_simu_body': +(* TODO - rewrite it with the new Codestate *) +(* Lemma step_simu_body': forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', (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' -> @@ -1524,8 +1532,7 @@ Lemma step_simu_body': (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) /\ exit tbb' = exit tbb ). Proof. -Admitted. -(* intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - intros until m'. intros Hnobuiltin BSTEP MCS. inv BSTEP. exists rs1, m1, tbb, nil. repeat (split; simpl; auto). @@ -1541,9 +1548,9 @@ Admitted. rewrite Hbody. rewrite Hbody'. rewrite app_assoc. auto. eapply exec_body_trans; eauto. congruence. -Qed. *) - -Theorem step_simu_body: +Qed. + *) +(* Theorem step_simu_body: forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', (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' -> @@ -1559,7 +1566,7 @@ Proof. intros (rs2 & m2 & tbb' & l & Hbody & EXEB & MCS & Hexit). exists rs2, m2, tbb', l. repeat (split; simpl; auto). inv MCS. econstructor; eauto. -Qed. +Qed. *) Lemma exec_body_straight: forall l rs0 m0 rs1 m1, -- cgit From e71af11d385f4763ec92daa7df4a2326c0c6001a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 23 Oct 2018 17:26:37 +0200 Subject: Avancement dans le schéma. Blocage sur step_simu_bblock' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgenproof.v | 291 +++++++++++++++++++++++++++++++++----------- 1 file changed, 219 insertions(+), 72 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 6a9e5661..a26f895c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1070,7 +1070,7 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (Asmblock.State rs m'). Record codestate := - mk_codestate { pstate: state; + Codestate { pstate: state; pheader: list label; pbody1: list basic; pbody2: list basic; @@ -1087,9 +1087,9 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (STACKS: match_stack ge s) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) (MEXT: Mem.extends m m0) - (TRANSBODY: transl_basic_code f (MB.body bb) ep = OK tbc) - (TRANSCTL: transl_instr_control f (MB.exit bb) = OK tbi) - (TRANSC: transl_blocks f c false = OK tc) + (TBC: transl_basic_code f (MB.body bb) ep = 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: ep = true -> rs0#FP = parent_sp s), @@ -1114,8 +1114,8 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := (PCeq: rs PC = Vptr fb ofs) (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) (GEN: gen_bblocks lhd tbdy tex = tbb::nil) - (HEADEROK: header tbb = lhd) - (BODYOK: body tbb = tbdy ++ extract_basic(tex)) + (HDROK: header tbb = lhd) + (BDYOK: body tbb = tbdy ++ extract_basic(tex)) , match_asmblock fb {| pstate := (Asmblock.State rs m); @@ -1130,6 +1130,7 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := (Asmblock.State rs m) . + Lemma transl_blocks_nonil: forall f bb c tc ep, transl_blocks f (bb::c) ep = OK tc -> @@ -1273,7 +1274,8 @@ Theorem match_state_codestate: mbs = (Machblock.State s fb sp (bb::c) ms m) -> match_states mbs abs -> exists cs fb, - match_codestate fb mbs cs /\ match_asmblock fb cs abs. + match_codestate fb mbs cs /\ match_asmblock fb cs abs + /\ 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. @@ -1287,9 +1289,51 @@ Proof. 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. - split; econstructor; eauto. + repeat split. all: econstructor; eauto. +Qed. + +Lemma gen_bblocks_eq: + forall c c' thd tbdy tbb, + extract_basic c = extract_basic c' -> + extract_ctl c = extract_ctl c' -> + gen_bblocks thd tbdy c = tbb::nil -> + exists tbb', + gen_bblocks thd tbdy c' = tbb'::nil + /\ body tbb' = body tbb /\ header tbb' = header tbb /\ exit tbb' = exit tbb. +Proof. + intros. + unfold gen_bblocks in *. rewrite <- H0. + destruct (extract_ctl c). + - destruct c0. destruct i. discriminate. + inv H1. eexists. split. eauto. split; eauto. simpl. congruence. + - destruct tbdy. + + inv H1. eexists. split; eauto. + + inv H1. eexists. split; eauto. simpl. split; auto. congruence. +Qed. + +Theorem match_transl_blocks: + forall mbs abs s fb sp bb c ms m tbb tc ep f cs, + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + cur cs = Some tbb -> rem cs = tc -> fpok cs = ep -> + match_codestate fb mbs cs -> + match_asmblock fb cs abs -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + exists tbb', + body tbb' = body tbb /\ header tbb' = header tbb /\ exit tbb' = exit tbb + /\ transl_blocks f (bb::c) ep = OK (tbb'::tc). +Proof. + intros until cs. intros Hmbs Hcur Hrem Hfpok MCS MAS FIND. + unfold transl_blocks. fold transl_blocks. + inv MCS. inv H. simpl in Hcur. inv Hcur. assert (f = f0) by congruence. subst f0. clear FIND0. + inv MAS. simpl. + unfold transl_block. + rewrite TBC. simpl. rewrite TIC; simpl. rewrite TBLS. simpl. + exploit gen_bblocks_eq; eauto. intros (tbb' & GEN' & Hbody & Hheader & Hexit). exists tbb'. + repeat (split; auto). rewrite GEN'. simpl. auto. Qed. + (* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) + (* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. Next Obligation. unfold wf_bblock. unfold non_empty_bblock. left; discriminate. @@ -1338,36 +1382,39 @@ Qed. Axiom TODO: False. (* TODO - rewrite it with the new Codestate *) -(* Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 tbb' tbb tc E0 S'' rs1 m1 cs2, +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) -> - cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> + pstate cs2 = (Asmblock.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = Some tbb -> + (* cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> *) match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmblock fb cs2 (Asmblock.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 (body tbb') rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn (exit tbb') tbb 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 Hcodestate MCS MAS ESTEP. inv ESTEP. - - inv MCS. inv MAS. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. inv ESTEP. + - inv MCS. inv MAS. simpl in *. destruct ctl. + (* MBcall *) - exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) + (* exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. right. rewrite <- H. discriminate. intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. - destruct tbb' as [hd' bdy' ex']; simpl in *. subst. + destruct tbb' as [hd' bdy' ex']; simpl in *. subst. *) 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 H12. + destruct s1 as [rf|fid]; simpl in H7. * (* Indirect call *) inv H1. * (* Direct call *) monadInv H1. @@ -1377,9 +1424,13 @@ Proof. econstructor; eauto. assert (f1 = f) by congruence. subst f1. exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. econstructor; eauto. econstructor; eauto. - eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H12. eauto. + inv Hcur. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + inv Hpstate. 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 TODO. @@ -1394,21 +1445,23 @@ Proof. destruct TODO. + (* MBreturn *) destruct TODO. - - inv MCS. inv MAS. - exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) + - 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. + *) 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. 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. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock. 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 |}. @@ -1426,7 +1479,7 @@ Proof. exists (a ::i l). split; auto. simpl. rewrite H2. auto. Qed. -Lemma transl_blocks_basic_step: +(* Lemma transl_blocks_basic_step: forall bb tbb c tc bi bdy x le f tbb' ep, transl_blocks f (bb::c) ep = OK (tbb::tc) -> MB.body bb = bi::(bdy) -> (bdy <> nil \/ MB.exit bb <> None) -> @@ -1438,37 +1491,41 @@ Lemma transl_blocks_basic_step: OK (tbb'::tc). Proof. Admitted. + *) (* TODO - rewrite it with the new Codestate *) -(* Lemma step_simu_basic: - forall bb bb' s fb sp tbb c ms m rs1 m1 tc ms' m' bi bdy, +Lemma step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (bdy <> nil \/ MB.exit bb <> None) -> +(* (bdy <> nil \/ MB.exit bb <> None) -> *) bb' = {| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |} -> basic_step ge s fb sp ms m bi ms' m' -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - (exists rs2 m2 tbb' l, - body tbb = l ++ body tbb' + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> +(* pstate cs2 = (State rs2 m2) -> pbody1 cs2 = 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 := pheader cs1; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; fpok := it1_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') - (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) - /\ exit tbb' = exit tbb). + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). Proof. - intros until bdy. intros Hbody Hnobuiltin Hnotempty Hbb' BSE MCS. inv MCS. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). + intros until bdy. intros Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. +(* exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). exploit transl_block_nobuiltin; eauto. left; rewrite Hbody; discriminate. - intros (lbi & le & TBC & TIC & Htbody & Htexit). + intros (lbi & le & TBC & TIC & Htbody & Htexit). *) rewrite Hbody in TBC. monadInv TBC. - assert (Hcorrect: wf_bblock (header tbb) (x ++ extract_basic le) (exit tbb)). { +(* assert (Hcorrect: wf_bblock (header tbb) (x ++ extract_basic le) (exit tbb)). { unfold wf_bblock. unfold non_empty_bblock. inv Hnotempty. - assert (x <> nil). eapply transl_basic_code_nonil; eauto. left. destruct x; try discriminate. contradict H0; simpl; auto. - right. rewrite Htexit. eapply transl_instr_control_nonil; eauto. - } + } *) (* remember {| header := header tbb; body := x ++ extract_basic le; exit := exit tbb; correct := Hcorrect |} as tbb'. - *) inv BSE. + *) inv BSTEP. - (* MBgetstack *) destruct TODO. (* simpl in EQ0. @@ -1504,7 +1561,7 @@ Proof. destruct TODO. - (* MBstore *) destruct TODO. -Qed. *) +Qed. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, @@ -1519,37 +1576,36 @@ Proof. simpl. rewrite EBI. eapply IHl; eauto. Qed. -(* TODO - rewrite it with the new Codestate *) -(* Lemma step_simu_body': - forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', +Lemma step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', (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' -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - (exists rs2 m2 tbb' l, - body tbb = l ++ body tbb' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') - (Codestate (State rs2 m2) (tbb'::tc) (Some tbb')) - /\ exit tbb' = exit tbb ). + 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 := pheader cs1; 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_remove_body 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 Hnobuiltin BSTEP MCS. inv BSTEP. - exists rs1, m1, tbb, nil. - repeat (split; simpl; auto). - - intros until m'. intros Hnobuiltin BSTEP MCS. inv BSTEP. + - intros until m'. intros 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 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. - intros (rs2 & m2 & tbb' & l & Hbody & EBODY & MCS' & Hexit). + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). simpl in *. - exploit IHbdy; simpl; auto. eapply H6. eauto. - intros (rs3 & m3 & tbb'' & l' & Hbody' & EBODY' & MCS'' & Hexit'). - exists rs3, m3, tbb'', (l++l'). - repeat (split; simpl; auto). - rewrite Hbody. rewrite Hbody'. rewrite app_assoc. auto. - eapply exec_body_trans; eauto. - congruence. + exploit IHbdy. 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. - *) + (* Theorem step_simu_body: forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1609,6 +1665,26 @@ Proof. 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' rs m rs' m' s'' c S1, @@ -1619,7 +1695,78 @@ Lemma step_simulation_bblock': 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. -Admitted. + intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. + remember (Machblock.State sf f sp (bb::c) rs m) as mbs. + remember (State rs0 m'0) as abs. inversion AT. + exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + destruct (mbsize bb) eqn:SIZE. + - (* case empty block *) + apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. monadInv H2. monadInv EQ. simpl in *. + monadInv EQ0. monadInv EQ. simpl in H4. inv H4. + 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. 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. + - (* non empty block *) + exploit mbsize_neqz. instantiate (1 := bb). rewrite SIZE. discriminate. intros Hnotempty. + exploit match_state_codestate. 2: eapply Hnotempty. all: eauto. + intros (cs1 & fb & MCS & MAS & Hpstate). + + assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). + { intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. } + inversion MCS. subst. + exploit step_simu_body; eauto. simpl. eauto. + simpl. intros (rs2 & m2 & cs2 & ep1 & Hcs2 & EXEB & MCS'). + + remember (mb_remove_body bb) as bb'. + assert (MB.body bb' = nil). + { subst. destruct bb as [hd bdy ex]; simpl; auto. } + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). + monadInv TRANSF'. remember {| pstate := State rs2 m2; pheader := _; pbody1 := _; + pbody2 := _; pctl := _; fpok := _; rem := _; cur := _ |} as cs2. + + exploit step_simu_control. 5: instantiate (1 := cs2). all: subst; simpl; eauto. + econstructor; eauto. + erewrite exec_body_pc. all: eauto. + assert (x = tf) by congruence. subst x. + (* TODO - stuck *) +(* + intros (S1' & MCS & MAS & cseq). subst. + assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). + intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. + exploit step_simu_body; eauto. intros (rs2 & m2 & tbb' & l & Hbody & EXES & MCS' & Hexit). + + remember (mb_remove_body bb) as bb'. + assert (MB.body bb' = nil). + subst. destruct bb as [hd bdy ex]; simpl; auto. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + exploit step_simu_control; eauto. + econstructor; eauto. + + erewrite exec_body_pc; eauto. + assert (x = tf) by congruence. subst x. eauto. + + intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). + exploit exec_body_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. + rewrite Hexit in EXECR. + exploit (exec_body_control); eauto. rewrite Hbody. eauto. intro EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. + eapply plus_one. eapply exec_step_internal; eauto. + assert (x = tf) by congruence. subst x. eapply find_bblock_tail; eauto. + *)Admitted. + (* intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. remember (Machblock.State sf f sp (bb::c) rs m) as mbs. remember (State rs0 m'0) as abs. inversion AT. -- cgit From 70fed34d1b8600019c50f6ff897f22794020fb31 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 23 Oct 2018 18:42:26 +0200 Subject: ajoute un axiom a virer plus tard --- mppa_k1c/Asmblock.v | 8 +++++++- mppa_k1c/Asmblockgenproof.v | 14 ++++++++++---- 2 files changed, 17 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 6afa6e56..db370d13 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -384,7 +384,11 @@ Coercion PCtlFlow: cf_instruction >-> control. (** * Definition of a bblock *) Definition non_empty_bblock (body: list basic) (exit: option control): Prop - := body <> nil \/ exit <> None. (* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type ? *) + := body <> nil \/ exit <> None. + +(* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type + in order to prove bblock_equality below +*) (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. @@ -405,6 +409,8 @@ Record bblock := mk_bblock { Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). Local Obligation Tactic := bblock_auto_correct. +Axiom bblock_equality: forall bb1 bb2, header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. + (* FIXME: redundant with definition in Machblock *) Definition length_opt {A} (o: option A) : nat := match o with diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index a26f895c..e1d895fa 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1292,6 +1292,7 @@ Proof. repeat split. all: econstructor; eauto. Qed. +(* TODO: à simplifier ? Remplacer le tbb' par tbb *) Lemma gen_bblocks_eq: forall c c' thd tbdy tbb, extract_basic c = extract_basic c' -> @@ -1318,9 +1319,9 @@ Theorem match_transl_blocks: match_codestate fb mbs cs -> match_asmblock fb cs abs -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - exists tbb', + (* exists tbb', body tbb' = body tbb /\ header tbb' = header tbb /\ exit tbb' = exit tbb - /\ transl_blocks f (bb::c) ep = OK (tbb'::tc). + /\ *) transl_blocks f (bb::c) ep = OK (tbb::tc). (* OK (tbb'::tc). *) Proof. intros until cs. intros Hmbs Hcur Hrem Hfpok MCS MAS FIND. unfold transl_blocks. fold transl_blocks. @@ -1328,8 +1329,13 @@ Proof. inv MAS. simpl. unfold transl_block. rewrite TBC. simpl. rewrite TIC; simpl. rewrite TBLS. simpl. - exploit gen_bblocks_eq; eauto. intros (tbb' & GEN' & Hbody & Hheader & Hexit). exists tbb'. - repeat (split; auto). rewrite GEN'. simpl. auto. + exploit gen_bblocks_eq; eauto. intros (tbb' & GEN' & Hbody & Hheader & Hexit). + (* exists tbb'. + repeat (split; auto). rewrite GEN'. simpl. auto. *) + apply f_equal. + rewrite GEN'. simpl. + exploit bblock_equality; eauto. + intro X; rewrite X; auto. Qed. (* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) -- cgit From 7b940603048de9b285cc1f1f76c2bf1fd8d090d3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Oct 2018 15:24:06 +0200 Subject: step_simulation_bblock is back! --- mppa_k1c/Asmblock.v | 2 +- mppa_k1c/Asmblockgenproof.v | 247 ++++++++++++++------------------------------ 2 files changed, 77 insertions(+), 172 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index db370d13..fb0f8c37 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -409,7 +409,7 @@ Record bblock := mk_bblock { Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). Local Obligation Tactic := bblock_auto_correct. -Axiom bblock_equality: forall bb1 bb2, header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +(* Axiom bblock_equality: forall bb1 bb2, header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. *) (* FIXME: redundant with definition in Machblock *) Definition length_opt {A} (o: option A) : nat := diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e1d895fa..93eac9d1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1103,7 +1103,6 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := rem := tc; cur := Some tbb |} - (* (Codestate (Asmblock.State rs m') (tbb::tc) (Some tbb')) *) . Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := @@ -1113,9 +1112,7 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := (TRANSF: transf_function f = OK tf) (PCeq: rs PC = Vptr fb ofs) (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) - (GEN: gen_bblocks lhd tbdy tex = tbb::nil) (HDROK: header tbb = lhd) - (BDYOK: body tbb = tbdy ++ extract_basic(tex)) , match_asmblock fb {| pstate := (Asmblock.State rs m); @@ -1126,7 +1123,6 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := fpok := ep; rem := tc; cur := Some tbb |} -(* (Codestate (Asmblock.State rs m) (tbb'::tc) (Some tbb)) *) (Asmblock.State rs m) . @@ -1273,8 +1269,13 @@ Theorem match_state_codestate: (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, + exists cs fb f tbb tc ep, match_codestate fb mbs cs /\ match_asmblock 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. @@ -1288,64 +1289,13 @@ Proof. right. eapply transl_instr_control_nonil; 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. - repeat split. all: econstructor; eauto. + pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep. + repeat split. 1-2: econstructor; eauto. 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. -(* TODO: à simplifier ? Remplacer le tbb' par tbb *) -Lemma gen_bblocks_eq: - forall c c' thd tbdy tbb, - extract_basic c = extract_basic c' -> - extract_ctl c = extract_ctl c' -> - gen_bblocks thd tbdy c = tbb::nil -> - exists tbb', - gen_bblocks thd tbdy c' = tbb'::nil - /\ body tbb' = body tbb /\ header tbb' = header tbb /\ exit tbb' = exit tbb. -Proof. - intros. - unfold gen_bblocks in *. rewrite <- H0. - destruct (extract_ctl c). - - destruct c0. destruct i. discriminate. - inv H1. eexists. split. eauto. split; eauto. simpl. congruence. - - destruct tbdy. - + inv H1. eexists. split; eauto. - + inv H1. eexists. split; eauto. simpl. split; auto. congruence. -Qed. - -Theorem match_transl_blocks: - forall mbs abs s fb sp bb c ms m tbb tc ep f cs, - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - cur cs = Some tbb -> rem cs = tc -> fpok cs = ep -> - match_codestate fb mbs cs -> - match_asmblock fb cs abs -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - (* exists tbb', - body tbb' = body tbb /\ header tbb' = header tbb /\ exit tbb' = exit tbb - /\ *) transl_blocks f (bb::c) ep = OK (tbb::tc). (* OK (tbb'::tc). *) -Proof. - intros until cs. intros Hmbs Hcur Hrem Hfpok MCS MAS FIND. - unfold transl_blocks. fold transl_blocks. - inv MCS. inv H. simpl in Hcur. inv Hcur. assert (f = f0) by congruence. subst f0. clear FIND0. - inv MAS. simpl. - unfold transl_block. - rewrite TBC. simpl. rewrite TIC; simpl. rewrite TBLS. simpl. - exploit gen_bblocks_eq; eauto. intros (tbb' & GEN' & Hbody & Hheader & Hexit). - (* exists tbb'. - repeat (split; auto). rewrite GEN'. simpl. auto. *) - apply f_equal. - rewrite GEN'. simpl. - exploit bblock_equality; eauto. - intro X; rewrite X; auto. -Qed. - - (* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) - -(* Program Definition remove_body (bb: AB.bblock) := {| AB.header := AB.header bb; AB.body := nil; AB.exit := AB.exit bb |}. -Next Obligation. - unfold wf_bblock. unfold non_empty_bblock. left; discriminate. -Qed. - *) - Definition mb_remove_body (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. @@ -1385,9 +1335,8 @@ Proof. - subst. Simpl. Qed. -Axiom TODO: False. +Axiom TODO: False. -(* TODO - rewrite it with the new Codestate *) 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 -> @@ -1396,7 +1345,6 @@ Theorem step_simu_control: pstate cs2 = (Asmblock.State rs2 m2) -> pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> cur cs2 = Some tbb -> - (* cs2 = Codestate (Asmblock.State rs2 m2) (tbb'::tc) (Some tbb) -> *) match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmblock fb cs2 (Asmblock.State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> @@ -1409,11 +1357,6 @@ Proof. - inv MCS. inv MAS. simpl in *. destruct ctl. + (* MBcall *) - (* exploit transl_blocks_distrib; eauto. (* rewrite <- H1. discriminate. *) - intros (TLB & TLBS). clear TRANS. exploit transl_block_nobuiltin; eauto. - right. rewrite <- H. discriminate. - intros (tbdy & tex & TBC & TIC & BEQ & EXEQ). clear TLB. - destruct tbb' as [hd' bdy' ex']; simpl in *. subst. *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1499,7 +1442,6 @@ Proof. Admitted. *) -(* TODO - rewrite it with the new Codestate *) Lemma step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1518,20 +1460,8 @@ Lemma step_simu_basic: Proof. intros until bdy. intros Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. simpl in *. inv Hpstate. -(* exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). - exploit transl_block_nobuiltin; eauto. left; rewrite Hbody; discriminate. - intros (lbi & le & TBC & TIC & Htbody & Htexit). *) rewrite Hbody in TBC. monadInv TBC. -(* assert (Hcorrect: wf_bblock (header tbb) (x ++ extract_basic le) (exit tbb)). { - unfold wf_bblock. unfold non_empty_bblock. - inv Hnotempty. - - assert (x <> nil). eapply transl_basic_code_nonil; eauto. left. destruct x; try discriminate. - contradict H0; simpl; auto. - - right. rewrite Htexit. eapply transl_instr_control_nonil; eauto. - } *) -(* remember {| header := header tbb; body := x ++ extract_basic le; exit := exit tbb; correct := Hcorrect |} - as tbb'. - *) inv BSTEP. + inv BSTEP. - (* MBgetstack *) destruct TODO. (* simpl in EQ0. @@ -1701,19 +1631,15 @@ Lemma step_simulation_bblock': 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 BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. - remember (Machblock.State sf f sp (bb::c) rs m) as mbs. - remember (State rs0 m'0) as abs. inversion AT. - exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. destruct (mbsize bb) eqn:SIZE. - - (* case empty block *) - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. monadInv H2. monadInv EQ. simpl in *. - monadInv EQ0. monadInv EQ. simpl in H4. inv H4. - inv ESTEP. inv BSTEP. + - 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. + 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. @@ -1724,84 +1650,63 @@ Proof. generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. eapply agree_exten; eauto. intros. Simpl. intros. discriminate. - - (* non empty block *) - exploit mbsize_neqz. instantiate (1 := bb). rewrite SIZE. discriminate. intros Hnotempty. - exploit match_state_codestate. 2: eapply Hnotempty. all: eauto. - intros (cs1 & fb & MCS & MAS & Hpstate). - - assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). - { intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. } - inversion MCS. subst. - exploit step_simu_body; eauto. simpl. eauto. - simpl. intros (rs2 & m2 & cs2 & ep1 & Hcs2 & EXEB & MCS'). - - remember (mb_remove_body bb) as bb'. - assert (MB.body bb' = nil). - { subst. destruct bb as [hd bdy ex]; simpl; auto. } - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). - monadInv TRANSF'. remember {| pstate := State rs2 m2; pheader := _; pbody1 := _; - pbody2 := _; pctl := _; fpok := _; rem := _; cur := _ |} as cs2. - - exploit step_simu_control. 5: instantiate (1 := cs2). all: subst; simpl; eauto. - econstructor; eauto. - erewrite exec_body_pc. all: eauto. - assert (x = tf) by congruence. subst x. - (* TODO - stuck *) -(* - intros (S1' & MCS & MAS & cseq). subst. - assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). - intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. - exploit step_simu_body; eauto. intros (rs2 & m2 & tbb' & l & Hbody & EXES & MCS' & Hexit). - - remember (mb_remove_body bb) as bb'. - assert (MB.body bb' = nil). - subst. destruct bb as [hd bdy ex]; simpl; auto. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - exploit step_simu_control; eauto. - econstructor; eauto. - - erewrite exec_body_pc; eauto. - assert (x = tf) by congruence. subst x. eauto. - - intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). - exploit exec_body_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. - rewrite Hexit in EXECR. - exploit (exec_body_control); eauto. rewrite Hbody. eauto. intro EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. - eapply plus_one. eapply exec_step_internal; eauto. - assert (x = tf) by congruence. subst x. eapply find_bblock_tail; eauto. - *)Admitted. - -(* intros until S1. intros BSTEP Hbb' Hbuiltin ESTEP MS. inversion MS. subst. - remember (Machblock.State sf f sp (bb::c) rs m) as mbs. - remember (State rs0 m'0) as abs. inversion AT. - exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - exploit match_state_codestate; eauto. - intros (S1' & MCS & MAS & cseq). subst. - assert (Hnobuiltin': forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)). - intros. destruct bb as [hd bdy ex]. simpl in *. apply Hbuiltin. - exploit step_simu_body; eauto. intros (rs2 & m2 & tbb' & l & Hbody & EXES & MCS' & Hexit). - - remember (mb_remove_body bb) as bb'. - assert (MB.body bb' = nil). - subst. destruct bb as [hd bdy ex]; simpl; auto. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - exploit step_simu_control; eauto. - econstructor; eauto. - - erewrite exec_body_pc; eauto. - assert (x = tf) by congruence. subst x. eauto. - - intros (rs3 & m3 & rs4 & m4 & EXES' & EXECR & MS'). - exploit exec_body_trans. eapply EXES. eauto. clear EXES EXES'. intro EXES. - rewrite Hexit in EXECR. - exploit (exec_body_control); eauto. rewrite Hbody. eauto. intro EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. - eapply plus_one. eapply exec_step_internal; eauto. - assert (x = tf) by congruence. subst x. eapply find_bblock_tail; eauto. -Qed. *) + - 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_body 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. exploit step_simu_body. + 2: eapply BSTEP. + all: eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). rename f0 into f. + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge fb = 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). + subst. exploit step_simu_control. + 9: eapply MCS'. + all: simpl; eauto. + rewrite Hpbody2. rewrite Hpctl. rewrite Hcur. + { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmblock_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 fb 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 (f = 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, -- cgit From 79e45b05693f932f122c46b0d9bece03ed2ae53c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Oct 2018 16:12:58 +0200 Subject: MBgetstack proof done! --- mppa_k1c/Asmblockgenproof.v | 27 +++++++++------------------ 1 file changed, 9 insertions(+), 18 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 93eac9d1..6b83d110 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1463,31 +1463,22 @@ Proof. rewrite Hbody in TBC. monadInv TBC. inv BSTEP. - (* MBgetstack *) - destruct TODO. -(* simpl in EQ0. - + 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. { destruct TODO. } intros (rs2 & EXECS & Hrs'1 & Hrs'2). eapply exec_straight_body in EXECS. destruct EXECS as (l & Hlbi & EXECB). - remember {| header := header tbb; body := x ++ extract_basic le; exit := exit tbb; correct := Hcorrect |} - as tbb'. - exists rs2, m1, tbb', l. subst. - repeat (split; simpl; auto). rewrite Htbody. apply app_assoc_reverse. - econstructor; eauto. eapply transl_blocks_basic_step; eauto. + exists rs2, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). 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. eapply agree_set_mreg; eauto with asmgen. - instantiate (1 := ep). intro Hep. rewrite <- DXP; auto. apply Hrs'2; try discriminate. -(* TODO *) - - - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto with asmgen. congruence. - simpl; congruence. - *) - (* MBsetstack *) + intro Hep. simpl in Hep. inv Hep. + - (* MBsetstack *) destruct TODO. - (* MBgetparam *) destruct TODO. -- cgit From ba4b3ba3ebf01c202cdd847796eccd00f20f63b0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Oct 2018 17:06:23 +0200 Subject: MBsetstack done! --- mppa_k1c/Asmblock.v | 4 ++-- mppa_k1c/Asmblockgenproof.v | 24 +++++++++++++++++++----- mppa_k1c/Asmblockgenproof1.v | 43 +++++++++++++++++-------------------------- 3 files changed, 38 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fb0f8c37..cf6fef3b 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -816,14 +816,14 @@ Definition eval_offset (ofs: offset) : ptrofs := end. Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) - (d: ireg) (a: ireg) (ofs: offset) := + (d: preg) (a: ireg) (ofs: offset) := match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with | None => Stuck | Some v => Next (rs#d <- v) m end. Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) - (s: ireg) (a: ireg) (ofs: offset) := + (s: preg) (a: ireg) (ofs: offset) := match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with | None => Stuck | Some m' => Next rs m' diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 6b83d110..ba6ecb66 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1445,11 +1445,9 @@ Admitted. Lemma step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> -(* (bdy <> nil \/ MB.exit bb <> None) -> *) bb' = {| MB.header := MB.header bb; 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 -> -(* pstate cs2 = (State rs2 m2) -> pbody1 cs2 = 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 := pheader cs1; pbody1 := tbdy'; pbody2 := pbody2 cs1; @@ -1467,7 +1465,7 @@ Proof. 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. { destruct TODO. } + exploit loadind_correct; eauto with asmgen. intros (rs2 & EXECS & Hrs'1 & Hrs'2). eapply exec_straight_body in EXECS. destruct EXECS as (l & Hlbi & EXECB). exists rs2, m1, l. @@ -1479,7 +1477,23 @@ Proof. eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. inv Hep. - (* MBsetstack *) - destruct TODO. + 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. destruct P as (l & Hlbi & EXECB). + exists rs', m2', l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). 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. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. - (* MBgetparam *) destruct TODO. - (* MBop *) @@ -1733,7 +1747,7 @@ Proof. 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). - + destruct TODO. (* MBbuiltin *) + + (* MBbuiltin *) destruct TODO. + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - (* internal function *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 08be374a..4abf1d52 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1277,16 +1277,16 @@ Proof. *)*) Qed. -(* + Lemma indexed_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) rd m, + forall chunk (mk_instr: ireg -> offset -> basic) rd m, (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge 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 -> base <> GPR31 -> rd <> PC -> exists rs', - exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m + exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m /\ rs'#rd = v /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. Proof. @@ -1296,11 +1296,8 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. unfold exec_load. rewrite B, LOAD. eauto. Simpl. - split; intros; Simpl. + split; intros; Simpl. auto. Qed. -*) - -Definition noscroll := 0. Lemma indexed_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) r1 m, @@ -1308,7 +1305,7 @@ Lemma indexed_store_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> GPR31 -> r1 <> GPR31 -> IR r1 <> PC -> + base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. @@ -1318,13 +1315,10 @@ Proof. intros (base' & ofs' & rs' & A & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite B, C, STORE. eauto. eauto. - destruct r1; try discriminate. contradiction NOT31'. auto. auto. -(* intros; Simpl. *) + unfold exec_store. rewrite B, C, STORE. eauto. eauto. auto. + intros; Simpl. rewrite C; auto. Qed. - - Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> @@ -1334,42 +1328,39 @@ Lemma loadind_correct: exec_straight ge c rs m k rs' m /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. Admitted. -(* intros until v; intros TR LOAD NOT31. +Proof. + intros until v; intros TR LOAD NOT31. assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs k + c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', - exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_basic_instr ge (mk_instr base' ofs') rs' m = exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } destruct A as (mk_instr & B & C). subst c. eapply indexed_load_access_correct; eauto with asmgen. -Qed. *) +Qed. -(* Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> base <> GPR31 -> exists rs', - exec_straight ge fn c rs m k rs' m' + exec_straight ge c rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros until m'; intros TR STORE NOT31. + intros until m'; intros TR STORE NOT31. assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs k + c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', - exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_basic_instr ge (mk_instr base' ofs') rs' m = exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } destruct A as (mk_instr & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. Qed. -*) - Ltac bsimpl := unfold exec_bblock; simpl. Lemma Pget_correct: -- cgit From f5435aa72f5e2c79927b2ee26f36afacd82ddfea Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Oct 2018 17:33:04 +0200 Subject: MBgetparam done! --- mppa_k1c/Asmblockgenproof.v | 61 +++++++++++++++++++++++++++++++++++++++++--- mppa_k1c/Asmblockgenproof1.v | 8 +++--- 2 files changed, 61 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ba6ecb66..5c8aeb74 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -639,12 +639,12 @@ Qed. *) So, the following integer measure will suffice to rule out the unwanted behaviour. *) -(* + Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. Proof. intros. change (IR FP) with (preg_of R10). red; intros. exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. *) +Qed. (** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) (* @@ -1495,7 +1495,62 @@ Proof. eapply agree_undef_regs; eauto with asmgen. simpl; intros. rewrite Q; auto with asmgen. - (* MBgetparam *) - destruct TODO. + 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. + destruct ep. + (* GPR31 contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. congruence. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. destruct P as (l & Hlbi & EXECB). + exists rs2, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). 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. + + 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. congruence. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. congruence. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. destruct EXES as (l & Hlbi & EXECB). + exists rs3, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). 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. + + 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 *) destruct TODO. - (* MBload *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 4abf1d52..74b8f8b5 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1394,22 +1394,20 @@ Proof. intros. rewrite H. Simpl. Qed. +*) + Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR31 -> exists rs', - exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m + exec_straight ge (loadind_ptr base ofs dst :: k) rs m k rs' m /\ rs'#dst = v /\ forall r, r <> PC -> r <> GPR31 -> 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 H1. auto. Qed. -*) - - -Definition nosroll := 0. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', -- cgit From 38c3e762876ec66efaab289394d200d12b19af6d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 25 Oct 2018 15:04:51 +0200 Subject: Adding "proof irrelevance" to bblocks --- mppa_k1c/Asmblock.v | 64 ++++++++++++++++++++++++++++++++++++++------------ mppa_k1c/Asmblockgen.v | 11 +++++---- 2 files changed, 55 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cf6fef3b..c6c549cd 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -384,17 +384,38 @@ Coercion PCtlFlow: cf_instruction >-> control. (** * Definition of a bblock *) Definition non_empty_bblock (body: list basic) (exit: option control): Prop - := body <> nil \/ exit <> None. + := body <> nil \/ exit <> None. -(* TODO: use booleans instead of Prop to enforce proof irrelevance in bblock type - in order to prove bblock_equality below -*) +Definition non_empty_body (body: list basic): bool := + match body with + | nil => false + | _ => true + end. + +Definition non_empty_exit (exit: option control): bool := + match exit with + | None => false + | _ => true + end. + +Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. + +Lemma non_empty_bblock_refl: + forall body exit, + non_empty_bblock body exit -> + Is_true (non_empty_bblockb body exit). +Proof. +(* intros. destruct body; destruct exit. + all: unfold non_empty_bblock; try (left; discriminate); try (right; discriminate). + simpl in H. inv H. *) +Admitted. (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. *) -Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := - non_empty_bblock body exit (* /\ builtin_alone body exit *). + +(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := + non_empty_bblock body exit (* /\ builtin_alone body exit *). *) (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -403,13 +424,27 @@ Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; - correct: wf_bblock header body exit + correct: Is_true (non_empty_bblockb body exit) }. -Ltac bblock_auto_correct := ((* split; *)try discriminate; try (left; discriminate); try (right; discriminate)). -Local Obligation Tactic := bblock_auto_correct. +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. + destruct b; simpl; auto. + - destruct p1, p2; auto. + - destruct p1. +Qed. + +Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +Proof. + destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. + intros; subst. + rewrite (Istrue_proof_irrelevant _ c1 c2). + auto. +Qed. -(* Axiom bblock_equality: forall bb1 bb2, header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. *) (* FIXME: redundant with definition in Machblock *) Definition length_opt {A} (o: option A) : nat := @@ -499,10 +534,7 @@ Program Definition bblock_single_inst (i: instruction) := | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} end. -(* Next Obligation. - bblock_auto_correct. -Qed. - *) + Program Definition bblock_basic_ctl (c: list basic) (i: option control) := match i with | Some i => {| header:=nil; body:=c; exit:=Some i |} @@ -513,7 +545,9 @@ Program Definition bblock_basic_ctl (c: list basic) (i: option control) := end end. Next Obligation. - constructor. subst; discriminate. + bblock_auto_correct. +Qed. Next Obligation. + bblock_auto_correct. Qed. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index a4c94e9b..634ba20c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -860,7 +860,7 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -Local Obligation Tactic := bblock_auto_correct. +(* Local Obligation Tactic := bblock_auto_correct. *) (* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := match c with @@ -884,10 +884,11 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr end . Next Obligation. - intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. -Qed. (* Next Obligation. - intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. -Qed. *) + bblock_auto_correct. intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. +Qed. +Next Obligation. + bblock_auto_correct. +Qed. Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := do c <- transl_basic_code f fb.(Machblock.body) ep; -- cgit From fb8e5ed9109f6fcfc24d0d325c1e06cb200fc989 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 26 Oct 2018 10:53:04 +0200 Subject: Enlèvement de Pnop inutiles pour le Pbuiltin MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 13 ++++++++----- mppa_k1c/Asmblockgenproof.v | 41 ++++++++++++++++++++++++++++++----------- 2 files changed, 38 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 634ba20c..ceee1810 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -878,15 +878,18 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr | 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)) => ({| header := hd; body := c++(Pnop::nil); exit := None |}) :: - ((PExpand (Pbuiltin ef args res)) ::b nil) + | Some (PExpand (Pbuiltin ef args res)) => + match c with + | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + | _ => {| header := hd; body := c; exit := None |} + :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + end | Some (PCtlFlow i) => {| header := hd; body := (c ++ extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil end . Next Obligation. - bblock_auto_correct. intros. constructor. intro. apply app_eq_nil in H. destruct H. discriminate. -Qed. -Next Obligation. + bblock_auto_correct. intros. constructor. apply not_eq_sym. auto. +Qed. Next Obligation. bblock_auto_correct. Qed. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 5c8aeb74..b635ba6e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1134,7 +1134,7 @@ Lemma transl_blocks_nonil: Proof. intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - destruct x1; simpl; eauto. Qed. @@ -1197,15 +1197,16 @@ 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 GENB. unfold gen_bblocks in GENB. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. destruct (extract_ctl tex) eqn:ECTL. - destruct c. - + destruct i. inv GENB. + + destruct i. 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. @@ -1263,6 +1264,22 @@ Proof. - 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. +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)) -> @@ -1282,11 +1299,12 @@ Proof. 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. } + { 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. @@ -1310,6 +1328,7 @@ 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 @@ -1317,11 +1336,11 @@ Lemma transl_block_nobuiltin: /\ body tbb = c ++ extract_basic c' /\ exit tbb = extract_ctl c'. Proof. - intros until tbb. intros Hnonil TLB. monadInv TLB. destruct Hnonil. + 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. + 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. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. Qed. Lemma nextblock_preserves: -- cgit From ca273c377dcdf2bb2d1baf2edc3bcf855a59cc98 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 26 Oct 2018 15:14:26 +0200 Subject: MBbuiltin proved --- mppa_k1c/Asmblockgenproof.v | 548 ++++++++++--------------------------------- mppa_k1c/Asmblockgenproof0.v | 68 ++++++ 2 files changed, 189 insertions(+), 427 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index b635ba6e..f72d8386 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -646,400 +646,6 @@ Proof. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. -(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) -(* -Theorem step_simulation: - forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros; inv MS. - -- (* Mlabel *) - left; eapply exec_straight_steps; eauto; intros. - monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. apply agree_nextinstr; auto. simpl; congruence. - -- (* Mgetstack *) - unfold load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto with asmgen. congruence. - simpl; congruence. - - -- (* Msetstack *) - unfold store_stack in H. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - left; eapply exec_straight_steps; eauto. - rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - inversion TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]]. - exists rs'; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. - -- (* Mgetparam *) - assert (f0 = f) by congruence; subst f0. - unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. -(* Opaque loadind. *) - left; eapply exec_straight_steps; eauto; intros. monadInv TR. - destruct ep. -(* GPR31 contains parent *) - exploit loadind_correct. eexact EQ. - instantiate (2 := rs0). rewrite DXP; eauto. congruence. - intros [rs1 [P [Q R]]]. - exists rs1; split. eauto. - split. 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. congruence. intros [rs1 [P [Q R]]]. - exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence. - intros [rs2 [S [T U]]]. - exists rs2; split. eapply exec_straight_trans; eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs1#FP <- (rs2#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. -- (* Mop *) - assert (eval_operation tge sp op (map rs args) m = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. split. auto. - apply agree_set_undef_mreg with rs0; 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. - -- (* Mload *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - inversion TR. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. congruence. - intros; auto with asmgen. - simpl; congruence. - - -- (* Mstore *) - assert (eval_addressing tge sp addr (map rs args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - left; eapply exec_straight_steps; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - exists rs2; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. - -- (* Mcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct ros as [rf|fid]; simpl in H; monadInv H5. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. -*) -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -(* -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. -*) -+ (* Direct call *) - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - 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 H. auto. } - -- (* Mbuiltin *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_builtin. eauto. eauto. - eapply find_instr_tail; eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x). - unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H1. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen. - congruence. - -- (* Mgoto *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H4. - exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. - left; exists (State rs' m'); split. - apply plus_one. econstructor; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - econstructor; eauto. - eapply agree_exten; eauto with asmgen. - congruence. -- (* Mcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_opt_steps_goto; eauto. - intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exists jmp; exists k; exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - exact B. -- (* Mcond false *) - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - inversion TR. - exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B). - exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - simpl. congruence. -- (* Mjumptable *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H6. -(* - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H5); intro NOOV. - exploit find_label_goto_label. eauto. eauto. - instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef). - Simpl. eauto. - eauto. - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H. intros LD; inv LD. - left; econstructor; split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail; eauto. - simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. - econstructor; eauto. - eapply agree_undef_regs; eauto. - simpl. intros. rewrite C; auto with asmgen. Simpl. - congruence. -*) -- (* Mreturn *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. simpl in H6; monadInv H6. - assert (NOOV: list_length_z tf.(fn_code) <= 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_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - -- (* internal function *) - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. - unfold store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - 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 := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i - Pget GPR8 RA ::i - storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *. - set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPR8 = rs0 RA). { apply V'. } - assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - rewrite H3. rewrite H4. - (* change (rs' GPR8) with (rs0 RA). *) - rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. - congruence. congruence. - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: - exec_straight tge tf - tf.(fn_code) rs0 m' - x0 rs3 m3'). - { change (fn_code tf) with tfbody; unfold tfbody. - apply exec_straight_step with rs2 m2'. - unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity. - reflexivity. - eapply exec_straight_trans. - - eexact U'. - - eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_nextinstr. 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 <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite V. - assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H6; 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 V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. - -- (* external function *) - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. apply agree_set_pair; auto. - -- (* return *) - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. -*) - Inductive match_states: Machblock.state -> Asmblock.state -> Prop := | match_states_intro: forall s fb sp c ep ms m m' rs f tf tc @@ -1447,20 +1053,6 @@ Proof. exists (a ::i l). split; auto. simpl. rewrite H2. auto. Qed. -(* Lemma transl_blocks_basic_step: - forall bb tbb c tc bi bdy x le f tbb' ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) -> - MB.body bb = bi::(bdy) -> (bdy <> nil \/ MB.exit bb <> None) -> - transl_basic_code f bdy (it1_is_parent true bi) = OK x -> - transl_instr_control f (MB.exit bb) = OK le -> - header tbb' = header tbb -> body tbb' = x ++ extract_basic le -> exit tbb' = exit tbb -> - transl_blocks f ({| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |}::c) - (it1_is_parent ep bi) = - OK (tbb'::tc). -Proof. -Admitted. - *) - Lemma step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1621,24 +1213,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -(* Theorem step_simu_body: - forall bb s fb sp tbb c ms m rs1 m1 tc ms' m', - (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' -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) (Codestate (State rs1 m1) (tbb::tc) (Some tbb)) -> - (exists rs2 m2 tbb' l, - body tbb = l ++ body tbb' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (mb_remove_body bb::c) ms' m') - (Codestate (State rs2 m2) (tbb'::tc) (Some tbb)) - /\ exit tbb' = exit tbb ). -Proof. - intros. exploit step_simu_body'; eauto. - intros (rs2 & m2 & tbb' & l & Hbody & EXEB & MCS & Hexit). - exists rs2, m2, tbb', l. repeat (split; simpl; auto). - inv MCS. econstructor; eauto. -Qed. *) - Lemma exec_body_straight: forall l rs0 m0 rs1 m1, l <> nil -> @@ -1809,6 +1383,101 @@ Definition measure (s: MB.state) : 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. 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. + Theorem step_simulation: forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1821,7 +1490,32 @@ Proof. 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 TODO. + + (* 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 *) diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 4074c4d6..13100cdc 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -90,6 +90,15 @@ 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') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := match rl with | nil => True @@ -110,6 +119,16 @@ Proof. auto. Qed. +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + (** * Agreement between Mach registers and processor registers *) Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { @@ -349,6 +368,55 @@ Proof. eapply extcall_args_match; eauto. Qed. +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + (* inspired from Mach *) Lemma find_label_tail: -- cgit From c4924047e03f3c7024c17a6f367897f695c4cd63 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 26 Oct 2018 17:51:45 +0200 Subject: Changing exec_straight to allow all instructions (prepare for MBtailcall proof) --- mppa_k1c/Asmblock.v | 35 +++++++++++++++ mppa_k1c/Asmblockgenproof.v | 105 ++++++++++++++++++++++++++++++++----------- mppa_k1c/Asmblockgenproof0.v | 36 ++++++++------- mppa_k1c/Asmblockgenproof1.v | 32 ++++++------- 4 files changed, 151 insertions(+), 57 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index c6c549cd..9da85fd0 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -506,6 +506,41 @@ Coercion PControl: control >-> instruction. Definition code := list instruction. Definition bcode := list basic. +Fixpoint basics_to_code (l: list basic) := + match l with + | nil => nil + | bi::l => (PBasic bi)::(basics_to_code l) + end. + +Fixpoint code_to_basics (c: code) := + match c with + | (PBasic i)::c => + match code_to_basics c with + | None => None + | Some l => Some (i::l) + end + | _::c => None + | nil => Some nil + end. + +Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. +Proof. + intros. induction c as [|i c]; simpl; auto. + rewrite IHc. auto. +Qed. + +Lemma code_to_basics_dist: + forall c c' l l', + code_to_basics c = Some l -> + code_to_basics c' = Some l' -> + code_to_basics (c ++ c') = Some (l ++ l'). +Proof. + induction c as [|i c]; simpl; auto. + - intros. inv H. simpl. auto. + - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. + inv H. erewrite IHc; eauto. auto. +Qed. + (** Asmblockgen will have to translate a Mach control into a list of instructions of the form i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index f72d8386..78aeba2a 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -925,7 +925,7 @@ Definition mb_remove_body (bb: MB.bblock) := Lemma exec_straight_pnil: forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop::nil) 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. @@ -1006,9 +1006,20 @@ Proof. 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 TODO. - + (* MBbuiltin *) + + (* MBtailcall *) destruct TODO. +(* 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. + * inv H1. + * monadInv H1. inv Hpstate. inv Hcur. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. + *) + + (* MBbuiltin (contradiction) *) assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). rewrite <- H in H1. contradict H1; auto. + (* MBgoto *) @@ -1040,17 +1051,44 @@ 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' rs1 m1 rs2 m2, + forall c c' lc rs1 m1 rs2 m2, exec_straight tge c rs1 m1 c' rs2 m2 -> - exists l, + code_to_basics c = Some lc -> + exists l ll, c = l ++ c' - /\ exec_body tge l rs1 m1 = Next rs2 m2. + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. Proof. induction c; try (intros; inv H; fail). - intros. inv H. - - exists (a ::i nil). split; auto. simpl. rewrite H7. auto. - - apply IHc in H8. destruct H8 as (l & Hc & EXECB). subst. - exists (a ::i l). split; auto. simpl. rewrite H2. auto. + 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: @@ -1078,12 +1116,17 @@ Proof. 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. destruct EXECS as (l & Hlbi & EXECB). - exists rs2, m1, l. + 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). remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + 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. eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. inv Hep. @@ -1095,10 +1138,14 @@ Proof. exploit storeind_correct; eauto with asmgen. rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - eapply exec_straight_body in P. destruct P as (l & Hlbi & EXECB). - exists rs', m2', l. + 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). remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + 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. @@ -1125,10 +1172,14 @@ Proof. instantiate (2 := rs1). rewrite DXP; eauto. congruence. intros [rs2 [P [Q R]]]. - eapply exec_straight_body in P. destruct P as (l & Hlbi & EXECB). - exists rs2, m1, l. + 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). remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + 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. @@ -1147,10 +1198,14 @@ Proof. eapply S. intros EXES. - eapply exec_straight_body in EXES. destruct EXES as (l & Hlbi & EXECB). - exists rs3, m1, l. + 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). remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + 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. } rewrite <- Hheadereq. subst. eapply match_codestate_intro; eauto. @@ -1213,7 +1268,7 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -Lemma exec_body_straight: +(* Lemma exec_body_straight: forall l rs0 m0 rs1 m1, l <> nil -> exec_body tge l rs0 m0 = Next rs1 m1 -> @@ -1228,7 +1283,7 @@ Proof. - 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. +Qed. *) Lemma exec_body_pc: forall l rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 13100cdc..2b9fe5ef 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -678,17 +678,17 @@ Variable fn: function. Instructions are taken from the first list instead of being fetched from memory. *) -Inductive exec_straight: list basic -> regset -> mem -> - list basic -> regset -> mem -> Prop := +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := | exec_straight_one: forall i1 c rs1 m1 rs2 m2, exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight (i1 :: c) rs1 m1 c rs2 m2 + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 | exec_straight_step: forall i c rs1 m1 rs2 m2 c' rs3 m3, exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight (i :: c) rs1 m1 c' rs3 m3. + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. Inductive exec_control_rel: option control -> bblock -> regset -> mem -> regset -> mem -> Prop := @@ -705,21 +705,23 @@ Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := exec_bblock_rel b rs1 m1 rs2 m2. Lemma exec_straight_body: - forall c rs1 m1 rs2 m2, + forall c l rs1 m1 rs2 m2, exec_straight c rs1 m1 nil rs2 m2 -> - exec_body ge c rs1 m1 = Next rs2 m2. + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. Proof. induction c as [|i c]. - - intros. inv H. - - intros. inv H. - + simpl. rewrite H7. auto. - + apply IHc in H8. rewrite <- H8. simpl. rewrite H2. auto. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. Qed. (* + contradict H4. generalize i1. induction c; simpl; try discriminate. intros i0 X; inversion X. subst. eapply IHc. eauto. *) -Theorem exec_straight_bblock: +(* 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 -> @@ -728,7 +730,7 @@ Proof. intros. econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto. inv H0. auto. -Qed. +Qed. *) Lemma exec_straight_trans: forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, @@ -747,7 +749,7 @@ Lemma exec_straight_two: exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> - exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. Proof. intros. apply exec_straight_step with rs2 m2; auto. apply exec_straight_one; auto. @@ -761,7 +763,7 @@ Lemma exec_straight_three: rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> rs4#PC = Val.offset_ptr rs3#PC Ptrofs.one -> - exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. Proof. intros. apply exec_straight_step with rs2 m2; auto. eapply exec_straight_two; eauto. @@ -847,7 +849,7 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -Lemma exec_straight_through: +(* 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 -> @@ -864,11 +866,11 @@ Proof. + 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 exec_straight_through_singleinst: forall a b rs1 m1 rs2 m2 rs2' m2' lb, bblock_single_inst (PBasic a) = b -> - exec_straight (a::nil) rs1 m1 nil rs2 m2 -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> nextblock b rs2 = rs2' -> m2 = m2' -> exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. Proof. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 74b8f8b5..40e3f444 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -320,7 +320,7 @@ Ltac ArgsInv := Definition bla := 0. -Inductive exec_straight_opt: list basic -> regset -> mem -> list basic -> regset -> mem -> Prop := +Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop := | exec_straight_opt_refl: forall c rs m, exec_straight_opt c rs m c rs m | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, @@ -1235,8 +1235,8 @@ Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, base <> GPR31 -> exists base' ofs' rs', - exec_straight_opt (indexed_memory_access mk_instr base ofs :: k) rs m - (mk_instr base' ofs' :: k) rs' m + exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m + (mk_instr base' ofs' ::g k) rs' m /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. @@ -1286,7 +1286,7 @@ Lemma indexed_load_access_correct: Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR31 -> rd <> PC -> exists rs', - exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m /\ rs'#rd = v /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. Proof. @@ -1307,7 +1307,7 @@ Lemma indexed_store_access_correct: Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> exists rs', - exec_straight ge (indexed_memory_access mk_instr base ofs :: k) rs m k rs' m' + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. @@ -1325,7 +1325,7 @@ Lemma loadind_correct: Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR31 -> exists rs', - exec_straight ge c rs m k rs' m + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. Proof. @@ -1347,7 +1347,7 @@ Lemma storeind_correct: Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> base <> GPR31 -> exists rs', - exec_straight ge c rs m k rs' m' + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros TR STORE NOT31. @@ -1367,7 +1367,7 @@ Lemma Pget_correct: forall (dst: gpreg) (src: preg) k (rs: regset) m, src = RA -> exists rs', - exec_straight ge (Pget dst src :: k) rs m k rs' m + exec_straight ge (Pget dst src ::g k) rs m k rs' m /\ rs'#dst = rs#src /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. @@ -1401,7 +1401,7 @@ Lemma loadind_ptr_correct: Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> base <> GPR31 -> exists rs', - exec_straight ge (loadind_ptr base ofs dst :: k) rs m k rs' m + exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m /\ rs'#dst = v /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. Proof. @@ -1414,7 +1414,7 @@ Lemma storeind_ptr_correct: Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> base <> GPR31 -> src <> GPR31 -> exists rs', - exec_straight ge (storeind_ptr src base ofs :: k) rs m k rs' m' + exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. @@ -1544,17 +1544,20 @@ Proof. rewrite D in STORE; clear D. eapply transl_store_access_correct; eauto with asmgen. Qed. +*) +Definition noscroll := 0. +(* Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> Mem.free m stk 0 f.(fn_stacksize) = Some m' -> agree ms (Vptr stk soff) rs -> Mem.extends m tm -> match_stack ge0 cs -> exists rs', exists tm', - exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' + exec_straight ge (make_epilogue f k) rs tm k rs' tm' /\ agree ms (parent_sp cs) rs' /\ Mem.extends m' tm' /\ rs'#RA = parent_ra cs @@ -1600,8 +1603,7 @@ Proof. intros. Simpl. rewrite C2; auto. Qed. - -*) + *) End CONSTRUCTORS. -- cgit From 9b63f18830e480b95209751c7cd689eba952b19f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 29 Oct 2018 16:25:50 +0100 Subject: MBtailcall proof --- mppa_k1c/Asmblockgenproof.v | 36 ++++++++++++++++++++++++++++-------- mppa_k1c/Asmblockgenproof0.v | 30 ++++++++++++++++++------------ mppa_k1c/Asmblockgenproof1.v | 20 ++++++++------------ 3 files changed, 54 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 78aeba2a..c5ca7cc7 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -962,6 +962,13 @@ Qed. Axiom TODO: False. +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. + 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 -> @@ -978,8 +985,10 @@ Theorem step_simu_control: /\ 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. + 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. @@ -998,16 +1007,15 @@ Proof. econstructor; eauto. assert (f1 = f) by congruence. subst f1. exploit return_address_offset_correct; eauto. intros; subst ra. - inv Hcur. repeat eexists. rewrite H6. econstructor; eauto. rewrite H7. econstructor; eauto. - inv Hpstate. 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 TODO. -(* destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + + (* MBtailcall *) (* destruct TODO. *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. assert (f0 = f) by congruence. subst f0. @@ -1016,9 +1024,21 @@ Proof. exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. destruct s1 as [rf|fid]; simpl in H13. * inv H1. - * monadInv H1. inv Hpstate. inv Hcur. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. - *) + * 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. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 2b9fe5ef..ec0e5c7b 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -718,19 +718,13 @@ Proof. rewrite <- H7. simpl. rewrite H1. auto. Qed. -(* + contradict H4. generalize i1. induction c; simpl; try discriminate. - intros i0 X; inversion X. subst. eapply IHc. eauto. *) - -(* 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. +(* Lemma exec_straight_body2: + forall c c' l rs1 m1 rs2 m2, + exec_straight (c++c') rs1 m1 c' rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. Proof. - intros. - econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto. - inv H0. auto. -Qed. *) +Admitted. *) Lemma exec_straight_trans: forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, @@ -743,6 +737,18 @@ 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 -> diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 40e3f444..b876754c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1377,13 +1377,11 @@ Proof. - intros. Simpl. Qed. -(* - Lemma Pset_correct: forall (dst: preg) (src: gpreg) k (rs: regset) m, dst = RA -> exists rs', - exec_straight ge fn (Pset dst src ::i k) rs m k rs' m + exec_straight ge (Pset dst src ::g k) rs m k rs' m /\ rs'#dst = rs#src /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. @@ -1394,8 +1392,6 @@ Proof. intros. rewrite H. Simpl. Qed. -*) - Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> @@ -1547,7 +1543,7 @@ Qed. *) Definition noscroll := 0. -(* + Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> @@ -1573,8 +1569,8 @@ Proof. unfold make_epilogue. rewrite chunk_of_Tptr in *. - exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 - ::i Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs tm). + exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) + rs tm). - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - congruence. - intros (rs1 & A1 & B1 & C1). @@ -1583,7 +1579,7 @@ Proof. apply mkagree; auto. rewrite C1; discriminate || auto. intro. rewrite C1; auto; destruct r; simpl; try discriminate. - + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs1 tm). auto. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. intros (rs2 & A2 & B2 & C2). econstructor; econstructor; split. * eapply exec_straight_trans. @@ -1592,8 +1588,8 @@ Proof. { eapply A2. } { apply exec_straight_one. simpl. rewrite (C2 GPR12) 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. (* auto. *) } } + * split. (* apply agree_nextinstr. *)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. @@ -1603,7 +1599,7 @@ Proof. intros. Simpl. rewrite C2; auto. Qed. - *) + End CONSTRUCTORS. -- cgit From 908035f9c5b64390272bf9f270df9b3691c568c0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 31 Oct 2018 12:27:31 +0100 Subject: Setting ep to false when the basicblock has a header. MBgoto done. MBgetparam needs fix --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 237 +++++++++++++++++++++++++++++++++++-------- mppa_k1c/Asmblockgenproof0.v | 97 ++++++++++++++++++ 3 files changed, 290 insertions(+), 48 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ceee1810..46b788fe 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -903,14 +903,12 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: match lmb with | nil => OK nil | mb :: lmb => - do lb <- transl_block f mb ep; + do lb <- transl_block f mb (if Machblock.header mb then ep else false); do lb' <- transl_blocks f lmb false; OK (lb ++ lb') end . - - Definition transl_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code) true; OK (mkfunction f.(Machblock.fn_sig) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c5ca7cc7..ff60e20e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -324,8 +324,9 @@ Qed. - destruct (Int.eq n Int.zero); TailNoLabel. - eapply transl_cond_op_label; eauto. *) +*) -Remark indexed_memory_access_label: +(* Remark indexed_memory_access_label: forall (mk_instr: ireg -> offset -> instruction) base ofs k, (forall r o, nolabel (mk_instr r o)) -> tail_nolabel k (indexed_memory_access mk_instr base ofs k). @@ -334,8 +335,9 @@ Proof. (* destruct Archi.ptr64. *) destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) -Qed. +Qed. *) +(* Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. @@ -357,13 +359,15 @@ Remark loadind_ptr_label: Proof. intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. Qed. +*) -Remark storeind_ptr_label: +(* Remark storeind_ptr_label: forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). Proof. intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. +Qed. *) +(* Remark transl_memory_access_label: forall (mk_instr: ireg -> offset -> instruction) addr args k c, (forall r o, nolabel (mk_instr r o)) -> @@ -423,57 +427,171 @@ Proof. destruct i; try (intros [A B]; apply B). intros. subst c. simpl. auto. Qed. +*) + +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. +Admitted. + +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_code_label: - forall lbl f c ep tc, - transl_code f c ep = OK tc -> - match Mach.find_label lbl c with +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_code f c' false = OK tc' + | 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. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). - generalize (Mach.is_label_correct lbl a). - destruct (Mach.is_label lbl a); intros. - subst a. simpl in EQ. exists x; auto. - eapply IHc; eauto. + 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 Mach.find_label lbl f.(Mach.fn_code) with - | None => find_label lbl tf.(fn_code) = None - | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc + 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 (list_length_z x.(fn_code))); inv EQ0. - monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. - (* destruct B. *) - eapply transl_code_label; eauto. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. 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: +Lemma find_label_goto_label: forall f tf lbl rs m c' b ofs, Genv.find_funct_ptr ge b = Some (Internal f) -> transf_function f = OK tf -> rs PC = Vptr b ofs -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> + 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]]. + 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'))). @@ -484,7 +602,6 @@ Proof. generalize (transf_function_no_overflow _ _ H0). omega. intros. apply Pregmap.gso; auto. Qed. -*) (** Existence of return addresses *) @@ -693,7 +810,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (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) ep = OK tbc) + (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)) *) @@ -732,6 +849,16 @@ Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := (Asmblock.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, @@ -744,16 +871,6 @@ Proof. - destruct x1; simpl; eauto. Qed. -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 - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - Lemma no_builtin_preserved: forall f ex x2, (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> @@ -781,7 +898,7 @@ 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 ep = OK (tbb :: nil) + -> 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. @@ -1014,7 +1131,7 @@ Proof. 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 TODO. *) + + (* MBtailcall *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1043,7 +1160,35 @@ Proof. assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). rewrite <- H in H1. contradict H1; auto. + (* MBgoto *) - destruct TODO. + 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. 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 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 TODO. + (* MBjumptable *) @@ -1147,7 +1292,7 @@ Proof. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } rewrite <- Hheadereq. subst. - eapply match_codestate_intro; eauto. + 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 *) @@ -1173,7 +1318,8 @@ Proof. eapply agree_undef_regs; eauto with asmgen. simpl; intros. rewrite Q; auto with asmgen. - (* MBgetparam *) - simpl in EQ0. + destruct TODO. +(* simpl in EQ0. assert (f0 = f) by congruence; subst f0. unfold Mach.load_stack in *. @@ -1198,7 +1344,8 @@ Proof. exists rs2, m1, ll. eexists. eexists. split. instantiate (1 := x). eauto. repeat (split; auto). - eapply basics_to_code_app; eauto. + { eapply basics_to_code_app; eauto. + destruct (MB.header bb). eauto. simpl. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } rewrite <- Hheadereq. subst. @@ -1236,7 +1383,7 @@ Proof. 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. + apply preg_of_not_FP; auto. *) - (* MBop *) destruct TODO. - (* MBload *) diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index ec0e5c7b..3db0c2cd 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -666,6 +666,103 @@ Proof. congruence. Qed. +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + Section STRAIGHTLINE. Variable ge: genv. -- cgit From 58457e9b1941ae5733bb4b289b08b52ccc7a2764 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 31 Oct 2018 17:58:46 +0100 Subject: Trying to change the proofs for the new ep. Stuck in step_simu_bblock' --- mppa_k1c/Asmblockgenproof.v | 107 ++++++++++++++++++++++++++++---------------- 1 file changed, 68 insertions(+), 39 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ff60e20e..33d1de66 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -815,7 +815,8 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (TBLS: transl_blocks f c false = OK tc) (* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) (AG: agree ms sp rs0) - (DXP: ep = true -> rs0#FP = parent_sp s), + (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 := (Asmblock.State rs0 m0); pheader := (MB.header bb); @@ -1031,7 +1032,8 @@ Proof. 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. eauto. + 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. @@ -1258,19 +1260,19 @@ Qed. Lemma step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := MB.header bb; MB.body := bdy; MB.exit := MB.exit bb |} -> + 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 := pheader cs1; pbody1 := tbdy'; pbody2 := pbody2 cs1; + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; pctl := pctl cs1; fpok := it1_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 Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + 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. @@ -1289,10 +1291,10 @@ Proof. 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. +(* 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 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 *) @@ -1311,15 +1313,14 @@ Proof. 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. +(* 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. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - (* MBgetparam *) - destruct TODO. -(* simpl in EQ0. + simpl in EQ0. assert (f0 = f) by congruence; subst f0. unfold Mach.load_stack in *. @@ -1331,8 +1332,8 @@ Proof. (* Opaque loadind. *) (* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) - monadInv EQ0. - destruct ep. + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep eqn:EPeq. (* GPR31 contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. congruence. @@ -1341,19 +1342,19 @@ Proof. 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. + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. repeat (split; auto). - { eapply basics_to_code_app; eauto. - destruct (MB.header bb). eauto. simpl. + { 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. + 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. congruence. intros [rs2 [P [Q R]]]. @@ -1374,16 +1375,15 @@ Proof. 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. } - rewrite <- Hheadereq. subst. + 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. *) + apply preg_of_not_FP; auto. - (* MBop *) destruct TODO. - (* MBload *) @@ -1405,36 +1405,56 @@ Proof. 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 |}. + +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', + cs1' = {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; fpok := (if MB.header bb then fpok cs1 else false); rem := rem cs1; cur := cur cs1 |} + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros. + eexists. split; eauto. + inv H1. simpl in *. inv H0. + 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 := pheader cs1; pbody1 := nil; pbody2 := pbody2 cs1; + 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_remove_body bb::c) ms' m') cs2). + /\ 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 Hnobuiltin BSTEP Hpstate MCS. + - 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 Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + - 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. + 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. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + 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 -> @@ -1534,17 +1554,26 @@ Proof. all: eauto. intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - (* step_simu_body part *) + (* 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. exploit step_simu_body. - 2: eapply BSTEP. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 3: eapply MCS. + all: eauto. + intros (cs1' & Heqcs1' & 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. + exploit step_simu_body. + 3: eapply BSTEP. all: eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). rename f0 into f. + { (* TODO *) } + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge fb = Some (Internal tf)). + 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). @@ -1555,7 +1584,7 @@ Proof. all: simpl; eauto. rewrite Hpbody2. rewrite Hpctl. rewrite Hcur. { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmblock_some; eauto. - erewrite exec_body_pc; eauto. } + erewrite exec_body_pc; eauto. destruct TODO. (* TODO *) } intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). (* bringing the pieces together *) -- cgit From 5397e5e8be051cf10934d59505666d335c018d90 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 5 Nov 2018 14:25:21 +0100 Subject: Got the schema working again with the headers --- mppa_k1c/Asmblockgenproof.v | 87 +++++++++++++++++++++++++++++---------------- 1 file changed, 57 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 33d1de66..8e9bc1fa 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -829,16 +829,16 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := |} . -Inductive match_asmblock fb: codestate -> Asmblock.state -> Prop := - | match_asmblock_some: +Inductive match_asmstate fb: codestate -> Asmblock.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) +(* (HDROK: header tbb = lhd) *) , - match_asmblock fb + match_asmstate fb {| pstate := (Asmblock.State rs m); pheader := lhd; pbody1 := tbdy; @@ -1011,7 +1011,7 @@ Theorem match_state_codestate: 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_asmblock fb cs abs + 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 @@ -1097,7 +1097,7 @@ Theorem step_simu_control: 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_asmblock fb cs2 (Asmblock.State rs1 m1) -> + match_asmstate fb cs2 (Asmblock.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 @@ -1407,22 +1407,45 @@ 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)) -> +(* (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', - cs1' = {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := (if MB.header bb then fpok cs1 else false); rem := rem cs1; cur := cur cs1 |} + exec_header cs1 cs1' /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). Proof. - intros. + intros until cs1. intros Hpstate MCS. eexists. split; eauto. - inv H1. simpl in *. inv H0. + 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 -> @@ -1454,7 +1477,6 @@ Proof. 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 -> @@ -1518,15 +1540,16 @@ Qed. (* Alternative form of step_simulation_bblock, easier to prove *) Lemma step_simulation_bblock': - forall sf f sp bb bb' rs m rs' m' s'' c S1, - 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'' -> + 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 BSTEP Hbb' Hbuiltin ESTEP MS. + 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. @@ -1559,17 +1582,18 @@ Proof. destruct H as (rs1 & m1 & Hpstate2). subst. assert (f = fb). { inv MCS. auto. } subst fb. exploit step_simu_header. - 3: eapply MCS. + 2: eapply MCS. all: eauto. - intros (cs1' & Heqcs1' & MCS2). + 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 (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. - all: eauto. - { (* TODO *) } + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). (* step_simu_control part *) @@ -1579,12 +1603,14 @@ Proof. 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'. + 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_asmblock_some; eauto. - erewrite exec_body_pc; eauto. destruct TODO. (* TODO *) } + { 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 *) @@ -1598,14 +1624,14 @@ Proof. intros EXECB. inv EXECB. exists (State rs4 m4). split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr fb ofs). + 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 (f = f0) by congruence. subst f0. + 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. @@ -1621,7 +1647,8 @@ Lemma step_simulation_bblock: 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. destruct bb as [hd bdy ex]; simpl in *. + 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. -- cgit From f30de37bdb8ef770f238cc968c29d1158c8d8f3f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 5 Nov 2018 17:00:20 +0100 Subject: MBreturn done --- mppa_k1c/Asmblockgen.v | 6 +++--- mppa_k1c/Asmblockgenproof.v | 27 ++++++++++++++++++++++----- 2 files changed, 25 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 46b788fe..a43b0485 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -821,7 +821,7 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co (** Translation of a code sequence *) -Definition it1_is_parent (before: bool) (i: Machblock.basic_inst) : bool := +Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := match i with | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst R10) @@ -836,7 +836,7 @@ Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_ins match il with | nil => OK nil | i1 :: il' => - do k <- transl_basic_code f il' (it1_is_parent it1p i1); + do k <- transl_basic_code f il' (fp_is_parent it1p i1); transl_instr_basic f i1 it1p k end. @@ -848,7 +848,7 @@ Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst match il with | nil => k nil | i1 :: il' => - transl_basic_rec f il' (it1_is_parent it1p i1) + transl_basic_rec f il' (fp_is_parent it1p i1) (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2) end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 8e9bc1fa..9f26e6fe 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -650,7 +650,7 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) -> + /\ (fp_is_parent ep i = true -> rs2#FP = parent_sp s)) -> exists st', plus step tge (State rs1 m1') E0 st' /\ match_states (Mach.State s fb sp c ms2 m2) st'. @@ -671,7 +671,7 @@ Lemma exec_straight_steps_goto: Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl f.(Mach.fn_code) = Some c' -> transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> + fp_is_parent ep i = false -> (forall k c (TR: transl_instr f i ep k = OK c), exists jmp, exists k', exists rs2, exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' @@ -708,7 +708,7 @@ Lemma exec_straight_opt_steps_goto: Genv.find_funct_ptr ge fb = Some (Internal f) -> Mach.find_label lbl f.(Mach.fn_code) = Some c' -> transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> + fp_is_parent ep i = false -> (forall k c (TR: transl_instr f i ep k = OK c), exists jmp, exists k', exists rs2, exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' @@ -1196,7 +1196,24 @@ Proof. + (* MBjumptable *) destruct TODO. + (* MBreturn *) - destruct TODO. + 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. 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). @@ -1267,7 +1284,7 @@ Lemma step_simu_basic: 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 := it1_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur 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). -- cgit From 9e2184dc81f6375140114208bd8a2db89b905d38 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 5 Nov 2018 17:54:36 +0100 Subject: Début de MBcond MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 15 ++++++ mppa_k1c/Asmblockgenproof1.v | 124 ++++++++++++++++++++++--------------------- 3 files changed, 81 insertions(+), 62 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index a43b0485..f09e2a73 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -133,7 +133,7 @@ Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. -(* Definition select_comp (n: int) (c: comparison) : option comparison := +Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then match c with | Ceq => Some Ceq @@ -142,7 +142,7 @@ Definition transl_compl end else None - . *) + . Definition transl_opt_compuimm (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 9f26e6fe..3344d1d2 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1193,6 +1193,21 @@ Proof. congruence. + (* MBcond *) destruct TODO. + (* 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. + + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + *) + (* MBjumptable *) destruct TODO. + (* MBreturn *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index b876754c..c0b0fb03 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -20,7 +20,7 @@ Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op Locations Machblock Conventions. Require Import Asmblock Asmblockgen Asmblockgenproof0. -(* (** Decomposition of integer constants. *) +(** Decomposition of integer constants. *) Lemma make_immed32_sound: forall n, @@ -57,8 +57,6 @@ Proof. *) Qed. -*) - Lemma make_immed64_sound: forall n, match make_immed64 n with @@ -137,10 +135,13 @@ Proof. intros; Simpl. Qed. *) + +*) + Lemma loadimm32_correct: forall rd n k rs m, exists rs', - exec_straight ge fn (loadimm32 rd n k) rs m k rs' m + exec_straight ge (loadimm32 rd n ::g k) rs m k rs' m /\ rs'#rd = Vint n /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. @@ -155,7 +156,7 @@ Qed. Lemma loadimm64_correct: forall rd n k rs m, exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m + exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m /\ rs'#rd = Vlong n /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. @@ -167,6 +168,7 @@ Proof. intros; Simpl. Qed. +(* (* Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) @@ -301,6 +303,7 @@ Proof. intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. Qed. *) +*) Ltac ArgsInv := repeat (match goal with @@ -316,10 +319,6 @@ Ltac ArgsInv := | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * end). -*) - -Definition bla := 0. - Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop := | exec_straight_opt_refl: forall c rs m, exec_straight_opt c rs m c rs m @@ -336,14 +335,13 @@ Proof. destruct 1; intros. auto. eapply exec_straight_trans; eauto. Qed. -(* Lemma transl_comp_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. esplit. split. @@ -351,13 +349,13 @@ Proof. - split. + intros; Simpl. + intros. - remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)). + assert (rs' # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmp_bool cmp rs##r1 rs##r2) as cmpbool. + remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. @@ -368,10 +366,10 @@ Qed. Lemma transl_compu_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. esplit. split. @@ -379,13 +377,13 @@ Proof. - split. + intros; Simpl. + intros. - remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)). + assert (rs' # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2) as cmpubool. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool. destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; destruct b0; simpl; auto. } @@ -395,10 +393,10 @@ Qed. Lemma transl_compl_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. esplit. split. @@ -406,13 +404,13 @@ Proof. - split. + intros; Simpl. + intros. - remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)). + assert (rs' # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmpl_bool cmp rs###r1 rs###r2) as cmpbool. + remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; unfold compare_long; unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; @@ -424,10 +422,10 @@ Qed. Lemma transl_complu_correct: forall cmp r1 r2 lbl k rs m b, exists rs', - exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. esplit. split. @@ -435,13 +433,13 @@ Proof. - split. + intros; Simpl. + intros. - remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)). + assert (rs' # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2) as cmpbool. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; unfold compare_long; unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; @@ -454,14 +452,14 @@ Lemma transl_opt_compuimm_correct: forall n cmp r1 lbl k rs m b c, select_comp n cmp = Some c -> exists rs', exists insn, - exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m (insn :: k) rs' m + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 (Vint n) = Some b -> - exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some insn) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. - unfold transl_opt_compuimm; rewrite H; simpl. +(* unfold transl_opt_compuimm. unfold select_comp in H. rewrite H; simpl. *) remember c as c'. destruct c'. - (* c = Ceq *) @@ -479,6 +477,7 @@ Proof. rewrite H'; simpl; auto; intros; contradict H; discriminate. } + unfold transl_opt_compuimm. subst. rewrite H'. exists rs, (Pcbu BTweqz r1 lbl). split. @@ -487,8 +486,7 @@ Proof. (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) auto; - unfold eval_branch. unfold getw. rewrite H0 in H2. unfold getw in H2. - rewrite H1. rewrite H2; auto. + unfold eval_branch. rewrite H0; auto. - (* c = Cne *) assert (Int.eq n Int.zero = true) as H'. { remember (Int.eq n Int.zero) as termz. destruct termz; auto. @@ -504,12 +502,14 @@ Proof. rewrite H'; simpl; auto; intros; contradict H; discriminate. } + unfold transl_opt_compuimm. subst. rewrite H'. + exists rs, (Pcbu BTwnez r1 lbl). split. * constructor. * split; auto. simpl. intros. auto; - unfold eval_branch. rewrite <- H0. rewrite H1. rewrite H2. auto. + unfold eval_branch. rewrite H0. auto. - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); destruct cmp; discriminate. - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); @@ -524,14 +524,14 @@ Lemma transl_opt_compluimm_correct: forall n cmp r1 lbl k rs m b c, select_compl n cmp = Some c -> exists rs', exists insn, - exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m (insn :: k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 (Vlong n) = Some b -> - exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some insn) rs' m = eval_branch fn lbl rs' m (Some b)) . Proof. intros. - unfold transl_opt_compluimm; rewrite H; simpl. +(* unfold transl_opt_compluimm; rewrite H; simpl. *) remember c as c'. destruct c'. - (* c = Ceq *) @@ -549,13 +549,14 @@ Proof. rewrite H'; simpl; auto; intros; contradict H; discriminate. } + unfold transl_opt_compluimm; subst; rewrite H'. exists rs, (Pcbu BTdeqz r1 lbl). split. * constructor. * split; auto. simpl. intros. auto; - unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + unfold eval_branch. rewrite H0; auto. - (* c = Cne *) assert (Int64.eq n Int64.zero = true) as H'. { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. @@ -571,12 +572,14 @@ Proof. rewrite H'; simpl; auto; intros; contradict H; discriminate. } + unfold transl_opt_compluimm; subst; rewrite H'. + exists rs, (Pcbu BTdnez r1 lbl). split. * constructor. * split; auto. simpl. intros. auto; - unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + unfold eval_branch. rewrite H0; auto. - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); destruct cmp; discriminate. - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); @@ -586,7 +589,7 @@ Proof. - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); destruct cmp; discriminate. Qed. - +(* Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -594,8 +597,8 @@ Lemma transl_cbranch_correct_1: agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' - /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) rs' m' = eval_branch fn lbl rs' m' (Some b) /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TRANSL EVAL AG MEXT. @@ -629,7 +632,7 @@ Proof. * constructor. * split; auto. destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; unfold getw; rewrite EVAL'; auto. + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez GPR31 lbl). @@ -638,7 +641,7 @@ Proof. with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. - { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } (* Ccompuimm *) - remember (select_comp n c0) as selcomp. @@ -718,8 +721,8 @@ Proof. { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } Qed. - -Lemma transl_cbranch_correct_true: + *) +(* Lemma transl_cbranch_correct_true: forall cond args lbl k c m ms sp rs m', transl_cbranch cond args lbl k = OK c -> eval_condition cond (List.map ms args) m = Some true -> @@ -749,7 +752,8 @@ Proof. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. intros; Simpl. Qed. - + *) +(* (** Translation of condition operators *) Lemma transl_cond_int32s_correct: -- cgit From 3811d877943c0724dc3abf03709849942e912aa9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 6 Nov 2018 15:54:56 +0100 Subject: MBcond true proved (but a small change needs to be done to Asmblockgenproof1) --- mppa_k1c/Asmblockgen.v | 5 +++ mppa_k1c/Asmblockgenproof.v | 75 ++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/Asmblockgenproof0.v | 15 +++++++++ mppa_k1c/Asmblockgenproof1.v | 59 ++++++++++++++++++++-------------- 4 files changed, 124 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f09e2a73..e16c701f 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -61,6 +61,7 @@ Definition make_immed64 (val: int64) := Imm64_single val. Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). +Notation "a ++g b" := (app (A:=instruction) 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 @@ -156,6 +157,10 @@ Definition transl_opt_compuimm loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP 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 diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 3344d1d2..237acc5e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1088,6 +1088,52 @@ 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 -> @@ -1192,8 +1238,7 @@ Proof. eauto with asmgen. congruence. + (* MBcond *) - destruct TODO. - (* destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. * (* MBcond true *) @@ -1202,12 +1247,30 @@ Proof. 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. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - *) + 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; Simpl. } + intros. discriminate. + + * destruct TODO. + + (* MBjumptable *) destruct TODO. + (* MBreturn *) diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 3db0c2cd..6a71a746 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -815,6 +815,21 @@ Proof. rewrite <- H7. simpl. rewrite H1. auto. Qed. +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + (* Lemma exec_straight_body2: forall c c' l rs1 m1 rs2 m2, exec_straight (c++c') rs1 m1 c' rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c0b0fb03..7bc60a65 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -75,7 +75,7 @@ Proof. auto. Qed. -(* + (** Properties of registers *) @@ -93,7 +93,7 @@ Qed. Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. -*) + (** Useful simplification tactic *) Ltac Simplif := @@ -589,7 +589,7 @@ Proof. - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); destruct cmp; discriminate. Qed. -(* + Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m', transl_cbranch cond args lbl k = OK c -> @@ -652,7 +652,12 @@ Proof. split. * apply A. * split; auto. apply C. apply EVAL'. - + unfold transl_opt_compuimm. rewrite <- Heqselcomp; simpl. + + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 GPR31 n ::g transl_comp c0 Unsigned x GPR31 lbl k). + { unfold transl_opt_compuimm. + destruct (Int.eq n Int.zero) eqn:EQN. + all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez GPR31 lbl). @@ -661,7 +666,7 @@ Proof. with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. - { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } (* Ccompl *) - exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). @@ -688,7 +693,7 @@ Proof. * constructor. * split; auto. destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; unfold getl; rewrite EVAL'; auto. + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez GPR31 lbl). @@ -697,7 +702,7 @@ Proof. with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. - { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } (* Ccompluimm *) @@ -709,7 +714,12 @@ Proof. split. * apply A. * split; auto. apply C. apply EVAL'. - + unfold transl_opt_compluimm. rewrite <- Heqselcomp; simpl. + + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 GPR31 n ::g transl_compl c0 Unsigned x GPR31 lbl k). + { unfold transl_opt_compluimm. + destruct (Int64.eq n Int64.zero) eqn:EQN. + all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez GPR31 lbl). @@ -718,23 +728,23 @@ Proof. with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. - { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } Qed. - *) -(* Lemma transl_cbranch_correct_true: - forall cond args lbl k c m ms sp rs m', + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m' tbb, transl_cbranch cond args lbl k = OK c -> eval_condition cond (List.map ms args) m = Some true -> agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' - /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. eapply transl_cbranch_correct_1 with (b := true); eauto. -Qed. +Proof. Admitted. +(* intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. *) Lemma transl_cbranch_correct_false: forall cond args lbl k c m ms sp rs m', @@ -742,17 +752,18 @@ Lemma transl_cbranch_correct_false: eval_condition cond (List.map ms args) m = Some false -> agree ms sp rs -> Mem.extends m m' -> - exists rs', - exec_straight ge fn c rs m' k rs' m' + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) rs' m' = Next rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. - intros. exploit transl_cbranch_correct_1; eauto. simpl. - intros (rs' & insn & A & B & C). - exists (nextinstr rs'). + intros. exploit transl_cbranch_correct_1; eauto. +(* intros (rs' & insn & A & B & C). + exists rs'. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. intros; Simpl. -Qed. - *) + *)Qed. + (* (** Translation of condition operators *) -- cgit From 74e7380dad6f6f72dbf39582cafb75cfc76cdd9b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 7 Nov 2018 16:13:12 +0100 Subject: MBcond false proven (modulo change needed in Asmblockgenproof1) --- mppa_k1c/Asmblockgenproof.v | 28 +++++++++++++++++++++++++++- mppa_k1c/Asmblockgenproof1.v | 10 +++++----- 2 files changed, 32 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 237acc5e..d6074848 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1269,8 +1269,34 @@ Proof. all: rewrite Hrs3; try discriminate; unfold nextblock; Simpl. } intros. discriminate. - * destruct TODO. + * (* 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. 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; Simpl. } + intros. discriminate. + (* MBjumptable *) destruct TODO. + (* MBreturn *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 7bc60a65..87888318 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -747,22 +747,22 @@ Proof. Admitted. Qed. *) Lemma transl_cbranch_correct_false: - forall cond args lbl k c m ms sp rs m', + forall cond args lbl k c m ms sp rs tbb m', transl_cbranch cond args lbl k = OK c -> eval_condition cond (List.map ms args) m = Some false -> agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' - /\ exec_control ge fn (Some insn) rs' m' = Next rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. exploit transl_cbranch_correct_1; eauto. +Proof. Admitted. +(* intros. exploit transl_cbranch_correct_1; eauto. *) (* intros (rs' & insn & A & B & C). exists rs'. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. intros; Simpl. - *)Qed. + *) (* (** Translation of condition operators *) -- cgit From a90988739214a8d9ffcaffea3f0bbc3367c01915 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 7 Nov 2018 16:40:11 +0100 Subject: Changes in Asmblockgenproof1 -> MBcond proved --- mppa_k1c/Asmblockgenproof1.v | 73 +++++++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 28 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 87888318..4269a153 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -336,12 +336,13 @@ Proof. Qed. Lemma transl_comp_correct: - forall cmp r1 r2 lbl k rs m b, + forall cmp r1 r2 lbl k rs m tbb b, exists rs', exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. esplit. split. @@ -350,9 +351,9 @@ Proof. + intros; Simpl. + intros. remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. @@ -364,12 +365,13 @@ Proof. Qed. Lemma transl_compu_correct: - forall cmp r1 r2 lbl k rs m b, + forall cmp r1 r2 lbl k rs m tbb b, exists rs', exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. esplit. split. @@ -378,9 +380,9 @@ Proof. + intros; Simpl. + intros. remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool. @@ -391,12 +393,13 @@ Proof. Qed. Lemma transl_compl_correct: - forall cmp r1 r2 lbl k rs m b, + forall cmp r1 r2 lbl k rs m tbb b, exists rs', exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. esplit. split. @@ -405,9 +408,9 @@ Proof. + intros; Simpl. + intros. remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. @@ -420,12 +423,13 @@ Proof. Qed. Lemma transl_complu_correct: - forall cmp r1 r2 lbl k rs m b, + forall cmp r1 r2 lbl k rs m tbb b, exists rs', exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. esplit. split. @@ -434,9 +438,9 @@ Proof. + intros; Simpl. + intros. remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' # GPR31 (Vint (Int.repr 0)) = Some b). + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). { - assert (rs' # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool. @@ -449,13 +453,13 @@ Proof. Qed. Lemma transl_opt_compuimm_correct: - forall n cmp r1 lbl k rs m b c, + forall n cmp r1 lbl k rs m b tbb c, select_comp n cmp = Some c -> exists rs', exists insn, exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 (Vint n) = Some b -> - exec_control ge fn (Some insn) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. @@ -483,6 +487,8 @@ Proof. split. * constructor. * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) auto; @@ -508,6 +514,8 @@ Proof. split. * constructor. * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0. auto. - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); @@ -521,13 +529,13 @@ Proof. Qed. Lemma transl_opt_compluimm_correct: - forall n cmp r1 lbl k rs m b c, + forall n cmp r1 lbl k rs m b tbb c, select_compl n cmp = Some c -> exists rs', exists insn, exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 (Vlong n) = Some b -> - exec_control ge fn (Some insn) rs' m = eval_branch fn lbl rs' m (Some b)) + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. intros. @@ -555,6 +563,8 @@ Proof. split. * constructor. * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0; auto. - (* c = Cne *) @@ -578,6 +588,8 @@ Proof. split. * constructor. * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0; auto. - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); @@ -591,17 +603,17 @@ Proof. Qed. Lemma transl_cbranch_correct_1: - forall cond args lbl k c m ms b sp rs m', + forall cond args lbl k c m ms b sp rs m' tbb, transl_cbranch cond args lbl k = OK c -> eval_condition cond (List.map ms args) m = Some b -> agree ms sp rs -> Mem.extends m m' -> exists rs', exists insn, exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' - /\ exec_control ge fn (Some insn) rs' m' = eval_branch fn lbl rs' m' (Some b) + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = eval_branch fn lbl (nextblock tbb rs') m' (Some b) /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. - intros until m'; intros TRANSL EVAL AG MEXT. + intros until tbb; intros TRANSL EVAL AG MEXT. set (vl' := map rs (map preg_of args)). assert (EVAL': eval_condition cond vl' m' = Some b). { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } @@ -631,6 +643,8 @@ Proof. split. * constructor. * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). @@ -692,6 +706,8 @@ Proof. split. * constructor. * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). @@ -742,9 +758,9 @@ Lemma transl_cbranch_correct_true: exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. Admitted. -(* intros. eapply transl_cbranch_correct_1 with (b := true); eauto. -Qed. *) +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. Lemma transl_cbranch_correct_false: forall cond args lbl k c m ms sp rs tbb m', @@ -756,8 +772,9 @@ Lemma transl_cbranch_correct_false: exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. Admitted. -(* intros. exploit transl_cbranch_correct_1; eauto. *) +Proof. + intros. exploit transl_cbranch_correct_1; eauto. +Qed. (* intros (rs' & insn & A & B & C). exists rs'. split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. -- cgit From 747b4e21c1d31a0d8a1d273ab159f9fd87822a1e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 7 Nov 2018 17:36:31 +0100 Subject: MBop proved --- mppa_k1c/Asmblockgenproof.v | 32 +++++++- mppa_k1c/Asmblockgenproof0.v | 8 +- mppa_k1c/Asmblockgenproof1.v | 192 ++++++++++++++++++++++--------------------- 3 files changed, 128 insertions(+), 104 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index d6074848..e049ac58 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1298,7 +1298,8 @@ Proof. all: rewrite <- C; try discriminate; unfold nextblock; Simpl. } intros. discriminate. + (* MBjumptable *) - destruct TODO. + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. + (* MBreturn *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1506,7 +1507,34 @@ Proof. simpl; intros. rewrite U; auto with asmgen. apply preg_of_not_FP; auto. - (* MBop *) - destruct TODO. + 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 *) destruct TODO. - (* MBstore *) diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 6a71a746..0c5055d3 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -287,7 +287,7 @@ Proof. Qed. *) -(* Lemma agree_set_undef_mreg: +Lemma agree_set_undef_mreg: forall ms sp rs r v rl rs', agree ms sp rs -> Val.lessdef v (rs'#(preg_of r)) -> @@ -300,7 +300,6 @@ Proof. congruence. auto. intros. rewrite Pregmap.gso; auto. Qed. - *) Lemma agree_change_sp: forall ms sp rs sp', @@ -865,8 +864,6 @@ Lemma exec_straight_two: forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> - rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. Proof. intros. apply exec_straight_step with rs2 m2; auto. @@ -878,9 +875,6 @@ Lemma exec_straight_three: exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one -> - rs3#PC = Val.offset_ptr rs2#PC Ptrofs.one -> - rs4#PC = Val.offset_ptr rs3#PC Ptrofs.one -> exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. Proof. intros. apply exec_straight_step with rs2 m2; auto. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 4269a153..3858571f 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -220,20 +220,23 @@ Proof. intros; Simpl. Qed. *) +*) + +Definition yolo := 4. Lemma opimm64_correct: forall (op: arith_name_rrr) (opi: arith_name_rri64) (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) -> + exec_basic_instr ge (op d s1 s2) rs m = Next ((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 (Vlong n)))) m) -> + exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) -> forall rd r1 n k rs, r1 <> GPR31 -> exists rs', - exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs##r1 (Vlong n) + exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. unfold opimm64. generalize (make_immed64_sound n); intros E. @@ -261,7 +264,7 @@ Lemma addptrofs_correct: forall rd r1 n k rs m, r1 <> GPR31 -> exists rs', - exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. @@ -274,9 +277,11 @@ Proof. - unfold addimm64. exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. split; auto. - rewrite B. unfold getw. destruct (rs r1); simpl; auto. + rewrite B. destruct (rs r1); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. Qed. + +(* (* Lemma addptrofs_correct_2: forall rd r1 n k (rs: regset) m b ofs, @@ -781,94 +786,93 @@ Qed. intros; Simpl. *) -(* (** Translation of condition operators *) Lemma transl_cond_int32s_correct: forall cmp rd r1 r2 k rs m, exists rs', - exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + exec_straight ge (basics_to_code (transl_cond_int32s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 rs#r2) rs'#rd /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. Lemma transl_cond_int32u_correct: forall cmp rd r1 r2 k rs m, exists rs', - exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs#r1 rs#r2 /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. Lemma transl_cond_int64s_correct: forall cmp rd r1 r2 k rs m, exists rs', - exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + exec_straight ge (basics_to_code (transl_cond_int64s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 rs#r2)) rs'#rd /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. Lemma transl_cond_int64u_correct: forall cmp rd r1 r2 k rs m, exists rs', - exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 rs#r2) /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. @@ -876,22 +880,22 @@ Lemma transl_condimm_int32s_correct: forall cmp rd r1 n k rs m, r1 <> GPR31 -> exists rs', - exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. @@ -899,22 +903,22 @@ Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, r1 <> GPR31 -> exists rs', - exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. @@ -922,22 +926,22 @@ Lemma transl_condimm_int64s_correct: forall cmp rd r1 n k rs m, r1 <> GPR31 -> exists rs', - exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. @@ -945,22 +949,22 @@ Lemma transl_condimm_int64u_correct: forall cmp rd r1 n k rs m, r1 <> GPR31 -> exists rs', - exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. Qed. @@ -968,7 +972,7 @@ Lemma transl_cond_op_correct: forall cond rd args k c rs m, transl_cond_op cond rd args k = OK c -> exists rs', - exec_straight ge fn c rs m k rs' m + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. Proof. @@ -977,30 +981,31 @@ Proof. intros until m; intros TR. destruct cond; simpl in TR; ArgsInv. + (* cmp *) - exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. + exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto. + (* cmpu *) - exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite B; auto. + (* cmpimm *) apply transl_condimm_int32s_correct; eauto with asmgen. + (* cmpuimm *) apply transl_condimm_int32u_correct; eauto with asmgen. + (* cmpl *) - exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exploit transl_cond_int64s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. + (* cmplu *) - exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. + (* cmplimm *) - exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. + (* cmpluimm *) - exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. Qed. +(* (* + (* cmpf *) destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. @@ -1059,6 +1064,7 @@ Qed. apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. split; intros; Simpl. *) +*) (** Some arithmetic properties. *) @@ -1075,18 +1081,18 @@ Qed. Lemma cast32signed_correct: forall (d s: ireg) (k: code) (rs: regset) (m: mem), exists rs': regset, - exec_straight ge fn (cast32signed d s k) rs m k rs' m + 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. Simpl. + + 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. Simpl. + + apply exec_straight_one. simpl. eauto with asmgen. + split. * Simpl. * intros. destruct r; Simpl. @@ -1103,15 +1109,15 @@ end. Ltac TranslOpSimpl := econstructor; split; - [ apply exec_straight_one; [simpl; eauto | reflexivity] - | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. + [ apply exec_straight_one; reflexivity + | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> exists rs', - exec_straight ge fn c rs m k rs' m + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ Val.lessdef v rs'#(preg_of res) /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. Proof. @@ -1123,8 +1129,8 @@ Opaque Int.eq. destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. - (* Oaddrsymbol *) destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). - exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. ++ set (rs1 := (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs (basics_to_code k) rs1 m); eauto with asmgen. intros (rs2 & A & B & C). exists rs2; split. apply exec_straight_step with rs1 m; auto. @@ -1139,22 +1145,22 @@ Opaque Int.eq. exists rs'; split; eauto. auto with asmgen. - (* Ocast8signed *) econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. unfold getw. + eapply exec_straight_two. simpl;eauto. simpl;eauto. + 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. auto. auto. + eapply exec_straight_two. simpl;eauto. simpl;eauto. split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. unfold getw. + 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 *) clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. ++ econstructor; split. apply exec_straight_one. simpl; eauto. split; intros; Simpl. + change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). econstructor; split. @@ -1162,7 +1168,7 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. - split; intros; unfold getw; Simpl. + split; intros; Simpl. - (* Ocast32signed *) exploit cast32signed_correct; eauto. intros (rs' & A & B & C). exists rs'; split; eauto. split. apply B. @@ -1170,8 +1176,8 @@ Opaque Int.eq. apply C; auto. - (* longofintu *) econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. - split; intros; Simpl. unfold getl; unfold Pregmap.set; Simpl. destruct (PregEq.eq x0 x0). + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + split; intros; Simpl. (* unfold Pregmap.set; Simpl. *) destruct (PregEq.eq x0 x0). + destruct (rs x0); auto. simpl. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. @@ -1257,11 +1263,7 @@ Opaque Int.eq. *) Qed. - (** Memory accesses *) -*) - -Definition no := 0. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, -- cgit From 88f6f275015eaa0ab5aac58eae93d2fa5e8f6b48 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 7 Nov 2018 17:49:03 +0100 Subject: MBload proved --- mppa_k1c/Asmblockgenproof.v | 26 +++++++++++++++++++++++++- mppa_k1c/Asmblockgenproof1.v | 30 ++++++++++++------------------ 2 files changed, 37 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e049ac58..8343272a 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1536,7 +1536,31 @@ Proof. Local Transparent destroyed_by_op. destruct op; simpl; auto; congruence. - (* MBload *) - destruct 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. + 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 *) destruct TODO. Qed. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 3858571f..d0c205cd 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1451,14 +1451,12 @@ Proof. intros. unfold Mptr. assert (Archi.ptr64 = true); auto. Qed. - -(* Lemma transl_memory_access_correct: forall mk_instr addr args k c (rs: regset) m v, transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> exists base ofs rs', - exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m + exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. @@ -1488,15 +1486,15 @@ Proof. Qed. Lemma transl_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c rd (rs: regset) m v v', + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge 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' -> rd <> PC -> exists rs', - exec_straight ge fn c rs m k rs' m + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#rd = v' /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. Proof. @@ -1506,19 +1504,19 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. + split; intros; Simpl. auto. Qed. Lemma transl_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c r1 (rs: regset) m v m', + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> r1 <> PC -> r1 <> GPR31 -> exists rs', - exec_straight ge fn c rs m k rs' m' + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros INSTR TR EV STORE NOTPC NOT31. @@ -1527,7 +1525,6 @@ Proof. econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. - intros; Simpl. Qed. Lemma transl_load_correct: @@ -1536,7 +1533,7 @@ Lemma transl_load_correct: eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', - exec_straight ge fn c rs m k rs' m + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. Proof. @@ -1544,7 +1541,7 @@ Proof. assert (A: exists mk_instr, transl_memory_access mk_instr addr args k = OK c /\ forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } destruct A as (mk_instr & B & C). eapply transl_load_access_correct; eauto with asmgen. @@ -1556,14 +1553,14 @@ Lemma transl_store_correct: eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.storev chunk m a rs#(preg_of src) = Some m' -> exists rs', - exec_straight ge fn c rs m k rs' m' + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. assert (A: exists mk_instr chunk', transl_memory_access mk_instr addr args k = OK c /\ (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). { unfold transl_store in TR; destruct chunk; ArgsInv; (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). @@ -1574,9 +1571,6 @@ Proof. rewrite D in STORE; clear D. eapply transl_store_access_correct; eauto with asmgen. Qed. -*) - -Definition noscroll := 0. Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, -- cgit From cc1480ca6a68b2bb6db1bf5e292da07f47d6705e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 8 Nov 2018 16:24:50 +0100 Subject: Proved MBstore -> all instructions are proved --- mppa_k1c/Asmblockgenproof.v | 29 +++++++++++++++++++++++++---- mppa_k1c/Asmblockgenproof0.v | 8 -------- 2 files changed, 25 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 8343272a..ee18e5e3 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -453,7 +453,8 @@ 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. -Admitted. + 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, @@ -1079,8 +1080,6 @@ Proof. - subst. Simpl. Qed. -Axiom TODO: False. - Lemma cons3_app {A: Type}: forall a b c (l: list A), a :: b :: c :: l = (a :: b :: c :: nil) ++ l. @@ -1562,7 +1561,29 @@ Local Transparent destroyed_by_op. simpl; congruence. - (* MBstore *) - destruct 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. + 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: diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 0c5055d3..e2b72295 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -829,14 +829,6 @@ Proof. + congruence. Qed. -(* Lemma exec_straight_body2: - forall c c' l rs1 m1 rs2 m2, - exec_straight (c++c') rs1 m1 c' rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. -Admitted. *) - Lemma exec_straight_trans: forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, exec_straight c1 rs1 m1 c2 rs2 m2 -> -- cgit From a72250529e0bdb7ef10283cfdc230b7978fd999d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 8 Nov 2018 16:25:10 +0100 Subject: Proved non_empty_bblock_refl (was Admitted) --- mppa_k1c/Asmblock.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9da85fd0..6235589c 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -405,10 +405,10 @@ Lemma non_empty_bblock_refl: non_empty_bblock body exit -> Is_true (non_empty_bblockb body exit). Proof. -(* intros. destruct body; destruct exit. - all: unfold non_empty_bblock; try (left; discriminate); try (right; discriminate). - simpl in H. inv H. *) -Admitted. + intros. destruct body; destruct exit. + all: simpl; auto. + inv H; contradiction. +Qed. (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. -- cgit From 9ac1af5d82c94d5476d1a7c9114dbde9581b80b2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 8 Nov 2018 16:48:20 +0100 Subject: Déterminisme prouvé -> Tout est prouvé MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 6235589c..557ab788 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1227,7 +1227,65 @@ Inductive final_state: state -> int -> Prop := Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). -Axiom semantics_determinate: forall p, determinate (semantics p). +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + + split. constructor. auto. + + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate. + rewrite H9 in H4. discriminate. + + unfold exec_bblock in H13. destruct (exec_body _ _ _ _); try discriminate. + rewrite H4 in H13. discriminate. + + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H6. eexact H13. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. Definition data_preg (r: preg) : bool := match r with -- cgit From f5074503d24b0974d880a402f1ecef6e7812c70e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 16 Nov 2018 15:40:26 +0100 Subject: Modified "Asmgen.*" error messages to "Asmblockgen.*" --- mppa_k1c/Asmblockgen.v | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e16c701f..2ac5cc16 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -34,10 +34,10 @@ Local Open Scope error_monad_scope. (** Extracting integer or float registers. *) Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. Definition freg_of (r: mreg) : res freg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. + 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 @@ -254,7 +254,7 @@ Definition transl_cbranch let (insn, normal) := transl_cond_single c rd r1 r2 in OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) *)| _, _ => - Error(msg "Asmgen.transl_cbranch") + Error(msg "Asmgenblock.transl_cbranch") end. (** Translation of a condition operator. The generated code sets the @@ -329,7 +329,7 @@ Definition transl_cond_op let (insn, normal) := transl_cond_single c rd r1 r2 in OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) *)| _, _ => - Error(msg "Asmgen.transl_cond_op") + Error(msg "Asmgenblock.transl_cond_op") end. (** Translation of the arithmetic operation [r <- op(args)]. @@ -341,7 +341,7 @@ Definition transl_op | Omove, a1 :: nil => match preg_of res, preg_of a1 with | IR r, IR a => OK (Pmv r a ::i k) - | _ , _ => Error(msg "Asmgen.Omove") + | _ , _ => Error(msg "Asmgenblock.Omove") end | Ointconst n, nil => do rd <- ireg_of res; @@ -639,7 +639,7 @@ Definition transl_op transl_cond_op cmp rd args k | _, _ => - Error(msg "Asmgen.transl_op") + Error(msg "Asmgenblock.transl_op") end. (** Accessing data in the stack frame. *) @@ -664,7 +664,7 @@ Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) : | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k) | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k) | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmgen.loadind") + | _, _ => Error (msg "Asmgenblock.loadind") end. Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := @@ -675,7 +675,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k) | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k) | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmgen.storeind") + | _, _ => Error (msg "Asmgenblock.storeind") end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := @@ -698,7 +698,7 @@ Definition transl_memory_access | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs ::i k) | _, _ => - Error(msg "Asmgen.transl_memory_access") + Error(msg "Asmgenblock.transl_memory_access") end. Definition transl_load (chunk: memory_chunk) (addr: addressing) @@ -729,7 +729,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) do r <- freg_of dst; transl_memory_access (Pfld r) addr args k | _ => - Error (msg "Asmgen.transl_load") + Error (msg "Asmgenblock.transl_load") end. Definition transl_store (chunk: memory_chunk) (addr: addressing) @@ -754,7 +754,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) do r <- freg_of src; transl_memory_access (Pfsd r) addr args k | _ => - Error (msg "Asmgen.transl_store") + Error (msg "Asmgenblock.transl_store") end. (** Function epilogue *) @@ -813,7 +813,7 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co OK (make_epilogue f (Pret ::g nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | _ => - Error (msg "Asmgen.transl_instr") + Error (msg "Asmgenblock.transl_instr") end end. -- cgit From bdaa3eb0ad6486186519ba1ba574e8ac92505cf0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 21 Nov 2018 17:03:24 +0100 Subject: Mise à jour vis à vis de CompCert 3.4 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 12 +++++++++++- mppa_k1c/Asmblockgen.v | 3 ++- mppa_k1c/Asmblockgenproof.v | 1 + mppa_k1c/Asmblockgenproof0.v | 18 ++++++++++++++++++ mppa_k1c/Asmexpand.ml | 7 ++----- mppa_k1c/Machblock.v | 2 +- 6 files changed, 35 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 557ab788..40df63e5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1130,6 +1130,16 @@ Definition preg_of (r: mreg) : preg := | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 end. +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + + (** Extract the values of the arguments of an external call. We exploit the calling conventions from module [Conventions], except that we use RISC-V registers instead of locations. *) @@ -1197,7 +1207,7 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct_ptr ge b = Some (External ef) -> external_call ef ge args m t res m' -> extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> step (State rs m) t (State rs' m') . diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 2ac5cc16..d024a74f 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -62,6 +62,7 @@ Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativ Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). 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 @@ -910,7 +911,7 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: | mb :: lmb => do lb <- transl_block f mb (if Machblock.header mb then ep else false); do lb' <- transl_blocks f lmb false; - OK (lb ++ lb') + OK (lb @@ lb') end . diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ee18e5e3..f97a71b1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -2088,6 +2088,7 @@ Local Transparent destroyed_at_function_entry. unfold loc_external_result. apply agree_set_other; auto. apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. - (* return *) inv MS. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index e2b72295..443e8757 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -13,6 +13,7 @@ Require Import Locations. Require Import Machblock. Require Import Asmblock. Require Import Asmblockgen. +Require Import Conventions1. Module MB:=Machblock. Module AB:=Asmblock. @@ -301,6 +302,23 @@ Proof. intros. rewrite Pregmap.gso; auto. Qed. +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (Asmblock.undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, Asmblock.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). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + Lemma agree_change_sp: forall ms sp rs sp', agree ms sp rs -> sp' <> Vundef -> diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 13869268..3b3b2b65 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -24,7 +24,7 @@ open Asmgen open Asmexpandaux open AST open Camlcoq -open Integers +open !Integers exception Error of string @@ -557,10 +557,7 @@ let preg_to_dwarf = let open Asmblock in function let expand_function id fn = try set_current_function fn; - if !Clflags.option_g then - expand_debug id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code - else - List.iter expand_instruction fn.fn_code; + expand id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code; Errors.OK (get_current_function ()) with Error s -> Errors.Error (Errors.msg (coqstring_of_camlstring s)) diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v index 44cec642..30393fd5 100644 --- a/mppa_k1c/Machblock.v +++ b/mppa_k1c/Machblock.v @@ -327,7 +327,7 @@ Inductive step: state -> trace -> state -> Prop := Genv.find_funct_ptr ge fb = Some (External ef) -> extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> external_call ef ge args m t res m' -> - rs' = set_pair (loc_result (ef_sig ef)) res rs -> + rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> step (Callstate s fb rs m) t (Returnstate s rs' m') | exec_return: -- cgit From be51963b3a2fca4e50059bcf1776c7b5b6bc5b63 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 23 Nov 2018 16:26:11 +0100 Subject: Changed ABI to match GCC - interoperability not tested yet --- mppa_k1c/Asmblock.v | 25 +++--- mppa_k1c/Asmblockgen.v | 24 +++--- mppa_k1c/Asmblockgenproof.v | 36 ++++---- mppa_k1c/Asmblockgenproof1.v | 196 +++++++++++++++++++++---------------------- mppa_k1c/Asmexpand.ml | 8 +- mppa_k1c/Conventions1.v | 15 ++-- mppa_k1c/Machregs.v | 33 ++++---- 7 files changed, 170 insertions(+), 167 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 40df63e5..1040d4c0 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -86,8 +86,9 @@ Module Pregmap := EMap(PregEq). (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) Notation "'SP'" := GPR12 (only parsing) : asm. -Notation "'FP'" := GPR10 (only parsing) : asm. -Notation "'RTMP'" := GPR31 (only parsing) : asm. +Notation "'FP'" := GPR14 (only parsing) : asm. +Notation "'GPRA'" := GPR16 (only parsing) : asm. +Notation "'RTMP'" := GPR32 (only parsing) : asm. Inductive btest: Type := | BTdnez (**r Double Not Equal to Zero *) @@ -935,7 +936,7 @@ Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset : let sp := (Vptr stk Ptrofs.zero) in match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with | None => Stuck - | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef) m2 + | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #RTMP <- Vundef) m2 end | Pfreeframe sz pos => @@ -946,7 +947,7 @@ Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset : | Vptr stk ofs => match Mem.free m stk 0 sz with | None => Stuck - | Some m' => Next (rs#SP <- v #GPR31 <- Vundef) m' + | Some m' => Next (rs#SP <- v #RTMP <- Vundef) m' end | _ => Stuck end @@ -1112,16 +1113,16 @@ Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcom register is reserved as temporary, to be used by the generated RV32G code. *) - (* FIXME - R31 is not there *) + (* FIXME - R16 and R32 are excluded *) Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 - | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) - | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 + | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | *) | R14 => GPR14 + | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 - | R30 => GPR30 | R32 => GPR32 | R33 => GPR33 | R34 => GPR34 + | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 @@ -1199,7 +1200,7 @@ Inductive step: state -> trace -> state -> Prop := rs' = nextblock bi (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#GPR31 <- Vundef))) -> + (rs#RTMP <- Vundef))) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1300,8 +1301,8 @@ Qed. Definition data_preg (r: preg) : bool := match r with | RA => false - | IR GPR31 => false - | IR GPR8 => false + | IR GPRA => false + | IR RTMP => false | IR _ => true | FR _ => true | PC => false diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index d024a74f..8bcbc712 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -25,6 +25,8 @@ Require Import Op Locations Machblock Asmblock. Local Open Scope string_scope. Local Open Scope error_monad_scope. +Notation "'MFP'" := R14 (only parsing). + (** 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 @@ -447,10 +449,10 @@ Definition transl_op | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs ::i k else - Psraiw GPR31 rs (Int.repr 31) ::i - Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i - Paddw GPR31 rs GPR31 ::i - Psraiw rd GPR31 n ::i k) + Psraiw RTMP rs (Int.repr 31) ::i + Psrliw RTMP RTMP (Int.sub Int.iwordsize n) ::i + Paddw RTMP rs RTMP ::i + Psraiw rd RTMP n ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => @@ -695,7 +697,7 @@ Definition transl_memory_access do rs <- ireg_of a1; OK (indexed_memory_access mk_instr rs ofs ::i k) | Aglobal id ofs, nil => - OK (Ploadsymbol id ofs GPR31 ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) + OK (Ploadsymbol id ofs RTMP ::i (mk_instr RTMP (Ofsimm Ptrofs.zero) ::i k)) | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs ::i k) | _, _ => @@ -761,8 +763,8 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) (** Function epilogue *) Definition make_epilogue (f: Machblock.function) (k: code) := - (loadind_ptr SP f.(fn_retaddr_ofs) GPR8) - ::g Pset RA GPR8 ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. + (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. *) @@ -830,8 +832,8 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := match i with | MBsetstack src ofs ty => before - | MBgetparam ofs ty dst => negb (mreg_eq dst R10) - | MBop op args res => before && negb (mreg_eq res R10) + | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) + | MBop op args res => before && negb (mreg_eq res MFP) | _ => false end. @@ -919,8 +921,8 @@ Definition transl_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code) true; OK (mkfunction f.(Machblock.fn_sig) (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b - Pget GPR8 RA ::b - storeind_ptr GPR8 SP f.(fn_retaddr_ofs) ::b lb)). + Pget GPRA RA ::b + storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb)). Fixpoint size_blocks (l: bblocks): Z := match l with diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index f97a71b1..686e8349 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -758,9 +758,9 @@ Qed. *) the unwanted behaviour. *) -Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r. +Remark preg_of_not_FP: forall r, negb (mreg_eq r R14) = true -> IR FP <> preg_of r. Proof. - intros. change (IR FP) with (preg_of R10). red; intros. + intros. change (IR FP) with (preg_of R14). red; intros. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. @@ -1455,7 +1455,7 @@ Proof. (* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. destruct ep eqn:EPeq. - (* GPR31 contains parent *) + (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. congruence. intros [rs2 [P [Q R]]]. @@ -2006,25 +2006,25 @@ Proof. (* Execution of function prologue *) monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b - Pget GPR8 RA ::b - storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *. + Pget GPRA RA ::b + storeind_ptr GPRA SP (fn_retaddr_ofs f) ::b x0) in *. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) - (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)). - exploit (Pget_correct tge GPR8 RA nil rs2 m2'); auto. + (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) GPR8 nil rs'' m2'). + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs'' m2'). rewrite chunk_of_Tptr in P. - assert (rs' GPR8 = rs0 RA). { apply V'. } - assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. } - assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. } - assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. } + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs'' GPRA = rs' GPRA). { subst. Simpl. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + assert (rs'' SP = rs' SP). { subst. Simpl. } rewrite H4. rewrite H3. rewrite H6. rewrite H5. - (* change (rs' GPR8) with (rs0 RA). *) + (* change (rs' GPRA) with (rs0 RA). *) rewrite ATLR. - change (rs2 GPR12) with sp. eexact P. + change (rs2 SP) with sp. eexact P. congruence. congruence. intros (rs3 & U & V). exploit (exec_straight_through_singleinst); eauto. @@ -2061,16 +2061,16 @@ Local Transparent destroyed_at_function_entry. unfold sp; congruence. intros. - assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto. - assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + 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. auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } rewrite Heqrs''. Simpl. rewrite H4 by auto with asmgen. reflexivity. - (* external function *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index d0c205cd..2b653236 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -79,19 +79,19 @@ Qed. (** Properties of registers *) -Lemma ireg_of_not_GPR31: - forall m r, ireg_of m = OK r -> IR r <> IR GPR31. +Lemma ireg_of_not_RTMP: + forall m r, ireg_of m = OK r -> IR r <> IR RTMP. Proof. intros. erewrite <- ireg_of_eq; eauto with asmgen. Qed. -Lemma ireg_of_not_GPR31': - forall m r, ireg_of m = OK r -> r <> GPR31. +Lemma ireg_of_not_RTMP': + forall m r, ireg_of m = OK r -> r <> RTMP. Proof. - intros. apply ireg_of_not_GPR31 in H. congruence. + intros. apply ireg_of_not_RTMP in H. congruence. Qed. -Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. +Hint Resolve ireg_of_not_RTMP ireg_of_not_RTMP': asmgen. (** Useful simplification tactic *) @@ -158,7 +158,7 @@ Lemma loadimm64_correct: exists rs', exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. destruct (make_immed64 n). @@ -179,18 +179,18 @@ Lemma opimm32_correct: (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 <> GPR31 -> + 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 <> GPR31 -> rs'#r = rs#r. + /\ 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 GPR31 hi lo (op rd r1 GPR31 :: k) rs m) +- 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. @@ -233,11 +233,11 @@ Lemma opimm64_correct: (forall d s n rs, exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) -> forall rd r1 n k rs, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m /\ rs'#rd = sem rs#r1 (Vlong n) - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. intros. unfold opimm64. generalize (make_immed64_sound n); intros E. destruct (make_immed64 n). @@ -245,7 +245,7 @@ Proof. apply exec_straight_one. rewrite H0. simpl; eauto. auto. split. Simpl. intros; Simpl. (* -- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) +- 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. @@ -262,11 +262,11 @@ Qed. Lemma addptrofs_correct: forall rd r1 n k rs m, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). @@ -285,12 +285,12 @@ Qed. (* Lemma addptrofs_correct_2: forall rd r1 n k (rs: regset) m b ofs, - r1 <> GPR31 -> rs#r1 = Vptr b of + 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 <> GPR31 -> rs'#r = rs#r. + /\ 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. @@ -299,10 +299,10 @@ Qed. (** Translation of conditional branches *) -Remark branch_on_GPR31: +Remark branch_on_RTMP: forall normal lbl (rs: regset) m b, - rs#GPR31 = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 X0 lbl) rs m = + 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. @@ -343,10 +343,10 @@ Qed. Lemma transl_comp_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', - exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -355,10 +355,10 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. @@ -372,10 +372,10 @@ Qed. Lemma transl_compu_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', - exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) (nextblock tbb rs') m + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -384,10 +384,10 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool. @@ -400,10 +400,10 @@ Qed. Lemma transl_compl_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', - exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -412,10 +412,10 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. @@ -430,10 +430,10 @@ Qed. Lemma transl_complu_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', - exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -442,10 +442,10 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool. @@ -626,13 +626,13 @@ Proof. destruct cond; simpl in TRANSL; ArgsInv. (* Ccomp *) - exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). + exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. + split; auto. apply C; auto. (* Ccompu *) - exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). + exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. + split; auto. apply C; auto. @@ -652,12 +652,12 @@ Proof. unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). + + exploit (loadimm32_correct RTMP n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). split. * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + with (c2 := (transl_comp c0 Signed x RTMP lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. { apply C'; auto. rewrite B, C; eauto with asmgen. } @@ -671,31 +671,31 @@ Proof. split. * apply A. * split; auto. apply C. apply EVAL'. - + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 GPR31 n ::g transl_comp c0 Unsigned x GPR31 lbl k). + + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 RTMP n ::g transl_comp c0 Unsigned x RTMP lbl k). { unfold transl_opt_compuimm. destruct (Int.eq n Int.zero) eqn:EQN. all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. all: discriminate. } rewrite H. clear H. - exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). + exploit (loadimm32_correct RTMP n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). split. * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + with (c2 := (transl_comp c0 Unsigned x RTMP lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } (* Ccompl *) - exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). + exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. + split; auto. apply C; auto. (* Ccomplu *) - exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). + exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. + split; auto. apply C; auto. @@ -715,12 +715,12 @@ Proof. unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). + + exploit (loadimm64_correct RTMP n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). split. * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + with (c2 := (transl_compl c0 Signed x RTMP lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. { apply C'; auto. rewrite B, C; eauto with asmgen. } @@ -735,18 +735,18 @@ Proof. split. * apply A. * split; auto. apply C. apply EVAL'. - + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 GPR31 n ::g transl_compl c0 Unsigned x GPR31 lbl k). + + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 RTMP n ::g transl_compl c0 Unsigned x RTMP lbl k). { unfold transl_opt_compluimm. destruct (Int64.eq n Int64.zero) eqn:EQN. all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. all: discriminate. } rewrite H. clear H. - exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). + exploit (loadimm64_correct RTMP n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). split. * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + with (c2 := (transl_compl c0 Unsigned x RTMP lbl k)) (rs2 := rs') (m2 := m'). eexact A. eexact A'. * split; auto. { apply C'; auto. rewrite B, C; eauto with asmgen. } @@ -762,7 +762,7 @@ Lemma transl_cbranch_correct_true: exists rs', exists insn, exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros. eapply transl_cbranch_correct_1 with (b := true); eauto. Qed. @@ -776,7 +776,7 @@ Lemma transl_cbranch_correct_false: exists rs', exists insn, exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros. exploit transl_cbranch_correct_1; eauto. Qed. @@ -878,11 +878,11 @@ Qed. Lemma transl_condimm_int32s_correct: forall cmp rd r1 n k rs m, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. @@ -901,11 +901,11 @@ Qed. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. @@ -924,11 +924,11 @@ Qed. Lemma transl_condimm_int64s_correct: forall cmp rd r1 n k rs m, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. @@ -947,11 +947,11 @@ Qed. Lemma transl_condimm_int64u_correct: forall cmp rd r1 n k rs m, - r1 <> GPR31 -> + r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. @@ -974,7 +974,7 @@ Lemma transl_cond_op_correct: exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). { destruct ob as [[]|]; reflexivity. } @@ -1141,7 +1141,7 @@ Opaque Int.eq. intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. + TranslOpSimpl. - (* Oaddrstack *) - exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). + exploit addptrofs_correct. instantiate (1 := SP); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. - (* Ocast8signed *) econstructor; split. @@ -1267,12 +1267,12 @@ Qed. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, - base <> GPR31 -> + base <> RTMP -> exists base' ofs' rs', exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m (mk_instr base' ofs' ::g k) rs' m /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. unfold indexed_memory_access; intros. (* destruct Archi.ptr64 eqn:SF. *) @@ -1318,11 +1318,11 @@ Lemma indexed_load_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge 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 -> - base <> GPR31 -> rd <> PC -> + base <> RTMP -> rd <> PC -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m /\ rs'#rd = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. exploit indexed_memory_access_correct; eauto. @@ -1339,10 +1339,10 @@ Lemma indexed_store_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> + base <> RTMP -> r1 <> RTMP -> r1 <> PC -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. exploit indexed_memory_access_correct. instantiate (1 := base). eauto. @@ -1357,11 +1357,11 @@ Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - base <> GPR31 -> + base <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR LOAD NOT31. assert (A: exists mk_instr, @@ -1379,10 +1379,10 @@ Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - base <> GPR31 -> + base <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR STORE NOT31. assert (A: exists mk_instr, @@ -1429,11 +1429,11 @@ Qed. Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> - base <> GPR31 -> + base <> RTMP -> exists rs', exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m /\ rs'#dst = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> 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 H1. auto. @@ -1442,10 +1442,10 @@ Qed. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - base <> GPR31 -> src <> GPR31 -> + base <> RTMP -> src <> RTMP -> exists rs', exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true); auto. @@ -1458,7 +1458,7 @@ Lemma transl_memory_access_correct: exists base ofs rs', exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until v; intros TR EV. unfold transl_memory_access in TR; destruct addr; ArgsInv. @@ -1496,7 +1496,7 @@ Lemma transl_load_access_correct: exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. Proof. intros until v'; intros INSTR TR EV LOAD NOTPC. exploit transl_memory_access_correct; eauto. @@ -1514,10 +1514,10 @@ Lemma transl_store_access_correct: 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.storev chunk m v rs#r1 = Some m' -> - r1 <> PC -> r1 <> GPR31 -> + r1 <> PC -> r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros INSTR TR EV STORE NOTPC NOT31. exploit transl_memory_access_correct; eauto. @@ -1535,7 +1535,7 @@ Lemma transl_load_correct: exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR EV LOAD. assert (A: exists mk_instr, @@ -1554,7 +1554,7 @@ Lemma transl_store_correct: Mem.storev chunk m a rs#(preg_of src) = Some m' -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. assert (A: exists mk_instr chunk', @@ -1586,7 +1586,7 @@ Lemma make_epilogue_correct: /\ Mem.extends m' tm' /\ rs'#RA = parent_ra cs /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> RTMP -> r <> GPRA -> rs'#r = rs#r). Proof. intros until tm; intros LP LRA FREE AG MEXT MCS. exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). @@ -1597,7 +1597,7 @@ Proof. unfold make_epilogue. rewrite chunk_of_Tptr in *. - exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) + exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPRA (Pset RA GPRA ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) rs tm). - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - congruence. @@ -1607,7 +1607,7 @@ Proof. apply mkagree; auto. rewrite C1; discriminate || auto. intro. rewrite C1; auto; destruct r; simpl; try discriminate. - + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. + + exploit (Pset_correct RA GPRA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. intros (rs2 & A2 & B2 & C2). econstructor; econstructor; split. * eapply exec_straight_trans. @@ -1615,7 +1615,7 @@ Proof. { eapply exec_straight_trans. { eapply A2. } { apply exec_straight_one. simpl. - rewrite (C2 GPR12) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. + 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. apply agree_change_sp with (Vptr stk soff). diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 3b3b2b65..45fe9b32 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -62,7 +62,7 @@ let expand_storeind_ptr src base ofs = (* Fix-up code around calls to variadic functions. Floating-point arguments residing in FP registers need to be moved to integer registers. *) -let int_param_regs = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |] +let int_param_regs = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11 |] (* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) let float_param_regs = [| |] @@ -441,20 +441,20 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (Asmblock.GPR10, Asmblock.GPR12)); + emit (Pmv (Asmblock.GPR14, Asmblock.GPR12)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); - expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; + expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; let va_ofs = Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); - expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; + expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 99044be8..7460b2e4 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -34,14 +34,15 @@ Require Import AST Machregs Locations. Definition is_callee_save (r: mreg) : bool := match r with - | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 - | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 => true + (* | R15 | R16 | R17 *) | R18 | R19 | R20 | R21 | R22 + | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true | _ => false end. Definition int_caller_save_regs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 - :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R10 :: R11 :: R15 (* :: R16 *) :: R17 + (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. @@ -49,8 +50,8 @@ Definition int_caller_save_regs := Definition float_caller_save_regs := R62 :: nil. (* FIXME - for the dummy_float_reg *) Definition int_callee_save_regs := - R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 - :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: nil. + (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 + :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. Definition float_callee_save_regs := @nil mreg. @@ -179,7 +180,7 @@ code can be introduced in the Asmexpand pass. *) Definition param_regs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil. + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: nil. Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) (rec: Z -> Z -> list (rpair loc)) := diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index bed3c040..41ea0979 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -38,13 +38,12 @@ Require Import Op. assembly-code generator [Asmgen]. *) -(* FIXME - no R31 *) Inductive mreg: Type := (* Allocatable General Purpose regs. *) - | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R9 - | R10 (* R11 to R14 res *) | R15 | R16 | R17 | R18 | R19 + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 + | R10 | R11 | (* R12 | R13 | *) R14 | R15 (* | R16 *) | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 - | R30 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 + | R30 | R31 (* | R32 *) | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 | R60 | R61 | R62 | R63. @@ -54,10 +53,10 @@ Proof. decide equality. Defined. Global Opaque mreg_eq. Definition all_mregs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 - :: R10 :: R15 :: R16 :: R17 :: R18 :: R19 + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R10 :: R11 (* :: R12 :: R13 *) :: R14 :: R15 (* :: R16 *) :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 - :: R30 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 + :: R30 :: R31 (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. @@ -86,12 +85,12 @@ Module IndexedMreg <: INDEXED_TYPE. Definition index (r: mreg): positive := match r with | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 - | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 - | R10 => 11 - | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 + | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 + | R10 => 11 | R11 => 12 (* | R12 => 13 | R13 => 14 *) | R14 => 15 + | R15 => 16 (* | R16 => 17 *) | R17 => 18 | R18 => 19 | R19 => 20 | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 - | R30 => 31 | R32 => 33 | R33 => 34 | R34 => 35 + | R30 => 31 | R31 => 32 (* | R32 => 33 *) | R33 => 34 | R34 => 35 | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 @@ -115,12 +114,12 @@ Local Open Scope string_scope. Definition register_names := ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) - :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R9" , R9) - :: ("R10", R10) - :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) + :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R8" , R8) :: ("R9" , R9) + :: ("R10", R10) :: ("R11", R11) (* :: ("R12", R12) :: ("R13", R13) *) :: ("R14", R14) + :: ("R15", R15) (* :: ("R16", R16) *) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) - :: ("R30", R30) :: ("R32", R32) :: ("R33", R33) :: ("R34", R34) + :: ("R30", R30) :: ("R31", R31) (* :: ("R32", R32) *) :: ("R33", R33) :: ("R34", R34) :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) @@ -175,9 +174,9 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := Definition destroyed_by_setstack (ty: typ): list mreg := nil. -Definition destroyed_at_function_entry: list mreg := R10 :: nil. +Definition destroyed_at_function_entry: list mreg := R14 :: nil. -Definition temp_for_parent_frame: mreg := R10. (* FIXME - and R8 ?? *) +Definition temp_for_parent_frame: mreg := R14. (* FIXME - ?? *) Definition destroyed_at_indirect_call: list mreg := nil. (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) -- cgit From 3d38bf85c8ac3a83fe7aaeb5e01bb9a8403e6a60 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 26 Nov 2018 15:31:46 +0100 Subject: Moved some files to mppa_k1c/lib ; reworked configure and Makefile to allow that --- mppa_k1c/Asmblockgenproof0.v | 1099 ----------------------- mppa_k1c/Asmgenproof1.v | 1585 --------------------------------- mppa_k1c/lib/Asmblockgenproof0.v | 1099 +++++++++++++++++++++++ mppa_k1c/lib/ForwardSimulationBlock.v | 322 +++++++ 4 files changed, 1421 insertions(+), 2684 deletions(-) delete mode 100644 mppa_k1c/Asmblockgenproof0.v delete mode 100644 mppa_k1c/Asmgenproof1.v create mode 100644 mppa_k1c/lib/Asmblockgenproof0.v create mode 100644 mppa_k1c/lib/ForwardSimulationBlock.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v deleted file mode 100644 index 443e8757..00000000 --- a/mppa_k1c/Asmblockgenproof0.v +++ /dev/null @@ -1,1099 +0,0 @@ -Require Import Coqlib. -Require Intv. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -Require Import Asmblockgen. -Require Import Conventions1. - -Module MB:=Machblock. -Module AB:=Asmblock. - -Hint Extern 2 (_ <> _) => congruence: asmgen. - -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. - -(* 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. - - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -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') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree 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 Mach.undef_regs_other; 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_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 -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -Qed. - -Lemma agree_undef_caller_save_regs: - forall ms sp rs, - agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (Asmblock.undef_caller_save_regs rs). -Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmblock.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). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -(* NB: these two lemma should go into [Coqlib.v] *) -Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). -Proof. - induction l1; simpl; auto with coqlib. -Qed. -Hint Resolve is_tail_app: coqlib. - -Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. -Proof. - induction l1; simpl; auto with coqlib. - intros l2 l3 H; inversion H; eauto with coqlib. -Qed. -Hint Resolve is_tail_app_inv: coqlib. - - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -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) -> - 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. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -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], - and [tc] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -Proof. - intros. destruct H. auto. -Qed. - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - 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 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -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). - all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H0. Simpl. discriminate. - destruct rs; try discriminate. inv H1. Simpl. - destruct rd; try discriminate. inv H1; Simpl. - auto. -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 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - 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 exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. auto. - simpl; auto. unfold nextblock; 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. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. \ No newline at end of file diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v deleted file mode 100644 index bb39b4a5..00000000 --- a/mppa_k1c/Asmgenproof1.v +++ /dev/null @@ -1,1585 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -Require Import Coqlib Errors Maps. -Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op Locations Mach Conventions. -Require Import Asm Asmgen Asmgenproof0. - -(** Decomposition of integer constants. *) - -Lemma make_immed32_sound: - forall n, - match make_immed32 n with - | Imm32_single imm => n = imm - end. -Proof. - intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). - predSpec Int.eq Int.eq_spec n lo; auto. -(* -- auto. -- set (m := Int.sub n lo). - assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). - assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). - { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. - auto using Int.eqmod_sub, Int.eqmod_refl. } - assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). - { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. - apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. - exists (two_p (32-12)); auto. } - assert (D: Int.modu m (Int.repr 4096) = Int.zero). - { apply Int.eqmod_mod_eq in C. unfold Int.modu. - change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. - reflexivity. - apply two_p_gt_ZERO; omega. } - rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. - rewrite Int.shl_mul_two_p. - change (two_p (Int.unsigned (Int.repr 12))) with 4096. - replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. - unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). - rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. - rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). - rewrite D. apply Int.add_zero. -*) -Qed. - -Lemma make_immed64_sound: - forall n, - match make_immed64 n with - | Imm64_single imm => n = imm -(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo - | Imm64_large imm => n = imm -*)end. -Proof. - intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). - predSpec Int64.eq Int64.eq_spec n lo. -- auto. -- set (m := Int64.sub n lo). - set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). - predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). - auto. - auto. -Qed. - -(** Properties of registers *) - -Lemma ireg_of_not_GPR31: - forall m r, ireg_of m = OK r -> IR r <> IR GPR31. -Proof. - intros. erewrite <- ireg_of_eq; eauto with asmgen. -Qed. - -Lemma ireg_of_not_GPR31': - forall m r, ireg_of m = OK r -> r <> GPR31. -Proof. - intros. apply ireg_of_not_GPR31 in H. congruence. -Qed. - -Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. - -(** Useful simplification tactic *) - -Ltac Simplif := - ((rewrite nextinstr_inv by eauto with asmgen) - || (rewrite nextinstr_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextinstr_pc) - || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -(** * Correctness of RISC-V constructor functions *) - -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', - exec_straight ge fn (loadimm32 rd n k) rs m k rs' m - /\ rs'#rd = Vint n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - -Lemma loadimm64_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - 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 <> GPR31 -> - 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 <> GPR31 -> 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 GPR31 hi lo (op rd r1 GPR31 :: 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) - (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 (Vlong n)))) m) -> - forall rd r1 n k rs, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs##r1 (Vlong n) - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. unfold opimm64. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. rewrite H0. simpl; eauto. auto. - split. Simpl. intros; Simpl. -(* -- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: 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 *) - -Lemma addptrofs_correct: - forall rd r1 n k rs m, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - unfold addptrofs; intros. - destruct (Ptrofs.eq_dec n Ptrofs.zero). -- subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. - intros; Simpl. -- unfold addimm64. - exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. - rewrite B. unfold getw. destruct (rs r1); simpl; auto. - 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 <> GPR31 -> 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 <> GPR31 -> 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_GPR31: - forall normal lbl (rs: regset) m b, - rs#GPR31 = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 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 - | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args - | [ H: bind _ _ = OK _ |- _ ] => monadInv H - | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - end); - subst; - repeat (match goal with - | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * - | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * - end). - -Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := - | exec_straight_opt_refl: forall c rs m, - exec_straight_opt c rs m c rs m - | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, - exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> - exec_straight_opt c1 rs1 m1 c2 rs2 m2. - -Remark exec_straight_opt_right: - forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, - exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> - exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> - exec_straight ge fn c1 rs1 m1 c3 rs3 m3. -Proof. - destruct 1; intros. auto. eapply exec_straight_trans; eauto. -Qed. - -Lemma transl_comp_correct: - forall cmp r1 r2 lbl k rs m b, - exists rs', - exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_comp. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). - { - assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmp_bool cmp rs##r1 rs##r2) as cmpbool. - destruct cmp; simpl; - unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compu_correct: - forall cmp r1 r2 lbl k rs m b, - exists rs', - exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_comp. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). - { - assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2) as cmpubool. - destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compl_correct: - forall cmp r1 r2 lbl k rs m b, - exists rs', - exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compl. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). - { - assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpl_bool cmp rs###r1 rs###r2) as cmpbool. - destruct cmp; simpl; - unfold compare_long; - unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_complu_correct: - forall cmp r1 r2 lbl k rs m b, - exists rs', - exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> - exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compl. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). - { - assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2) as cmpbool. - destruct cmp; simpl; - unfold compare_long; - unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_opt_compuimm_correct: - forall n cmp r1 lbl k rs m b c, - select_comp n cmp = Some c -> - exists rs', exists insn, - exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m (insn :: k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 (Vint n) = Some b -> - exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. - unfold transl_opt_compuimm; rewrite H; simpl. - remember c as c'. - destruct c'. - - (* c = Ceq *) - assert (Int.eq n Int.zero = true) as H'. - { remember (Int.eq n Int.zero) as termz. destruct termz; auto. - generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int.repr 0)) as H0. { - destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. - generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. - rewrite H'. discriminate. - } - assert (Ceq = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - - exists rs, (Pcbu BTweqz r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. - { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) - auto; - unfold eval_branch. unfold getw. rewrite H0 in H2. unfold getw in H2. - rewrite H1. rewrite H2; auto. - - (* c = Cne *) - assert (Int.eq n Int.zero = true) as H'. - { remember (Int.eq n Int.zero) as termz. destruct termz; auto. - generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int.repr 0)) as H0. { - destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. - generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. - rewrite H'. discriminate. - } - assert (Cne = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - exists rs, (Pcbu BTwnez r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - auto; - unfold eval_branch. rewrite <- H0. rewrite H1. rewrite H2. auto. - - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. -Qed. - -Lemma transl_opt_compluimm_correct: - forall n cmp r1 lbl k rs m b c, - select_compl n cmp = Some c -> - exists rs', exists insn, - exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m (insn :: k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 (Vlong n) = Some b -> - exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) - . -Proof. - intros. - unfold transl_opt_compluimm; rewrite H; simpl. - remember c as c'. - destruct c'. - - (* c = Ceq *) - assert (Int64.eq n Int64.zero = true) as H'. - { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. - generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int64.repr 0)) as H0. { - destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. - generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. - rewrite H'. discriminate. - } - assert (Ceq = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - - exists rs, (Pcbu BTdeqz r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - auto; - unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. - - (* c = Cne *) - assert (Int64.eq n Int64.zero = true) as H'. - { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. - generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int64.repr 0)) as H0. { - destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. - generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. - rewrite H'. discriminate. - } - assert (Cne = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - exists rs, (Pcbu BTdnez r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - auto; - unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. - - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. -Qed. - -Lemma transl_cbranch_correct_1: - forall cond args lbl k c m ms b sp rs m', - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some b -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' - /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until m'; intros TRANSL EVAL AG MEXT. - set (vl' := map rs (map preg_of args)). - assert (EVAL': eval_condition cond vl' m' = Some b). - { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } - clear EVAL MEXT AG. - destruct cond; simpl in TRANSL; ArgsInv. -(* Ccomp *) -- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccompu *) -- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccompimm *) -- remember (Int.eq n Int.zero) as eqz. - destruct eqz. - + assert (n = (Int.repr 0)). { - destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. - generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. - rewrite <- Heqeqz. discriminate. - } - exists rs, (Pcb (btest_for_cmpswz c0) x lbl). - split. - * constructor. - * split; auto. - destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; unfold getw; rewrite EVAL'; auto. - + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - * split; auto. - { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } -(* Ccompuimm *) -- remember (select_comp n c0) as selcomp. - destruct selcomp. - + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. - intros (rs' & i & A & B & C). - exists rs', i. - split. - * apply A. - * split; auto. apply C. apply EVAL'. - + unfold transl_opt_compuimm. rewrite <- Heqselcomp; simpl. - exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - * split; auto. - { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } -(* Ccompl *) -- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccomplu *) -- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez GPR31 lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccomplimm *) -- remember (Int64.eq n Int64.zero) as eqz. - destruct eqz. - + assert (n = (Int64.repr 0)). { - destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. - generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. - rewrite <- Heqeqz. discriminate. - } - exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). - split. - * constructor. - * split; auto. - destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; unfold getl; rewrite EVAL'; auto. - + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - * split; auto. - { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } - -(* Ccompluimm *) -- remember (select_compl n c0) as selcomp. - destruct selcomp. - + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. - intros (rs' & i & A & B & C). - exists rs', i. - split. - * apply A. - * split; auto. apply C. apply EVAL'. - + unfold transl_opt_compluimm. rewrite <- Heqselcomp; simpl. - exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). - exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez GPR31 lbl). - split. - * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. - * split; auto. - { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } -Qed. - -Lemma transl_cbranch_correct_true: - forall cond args lbl k c m ms sp rs m', - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some true -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', exists insn, - exec_straight_opt c rs m' (insn :: k) rs' m' - /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. eapply transl_cbranch_correct_1 with (b := true); eauto. -Qed. - -Lemma transl_cbranch_correct_false: - forall cond args lbl k c m ms sp rs m', - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some false -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', - exec_straight ge fn c rs m' k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. exploit transl_cbranch_correct_1; eauto. simpl. - intros (rs' & insn & A & B & C). - exists (nextinstr rs'). - split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. - intros; Simpl. -Qed. - -(** Translation of condition operators *) - -Lemma transl_cond_int32s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_int32u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_int64s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_int64u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m - /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int32s_correct: - forall cmp rd r1 n k rs m, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int32u_correct: - forall cmp rd r1 n k rs m, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int64s_correct: - forall cmp rd r1 n k rs m, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int64u_correct: - forall cmp rd r1 n k rs m, - r1 <> GPR31 -> - exists rs', - exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m - /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_op_correct: - forall cond rd args k c rs m, - transl_cond_op cond rd args k = OK c -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. -Proof. - assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). - { destruct ob as [[]|]; reflexivity. } - intros until m; intros TR. - destruct cond; simpl in TR; ArgsInv. -+ (* cmp *) - exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpu *) - exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B; auto. -+ (* cmpimm *) - apply transl_condimm_int32s_correct; eauto with asmgen. -+ (* cmpuimm *) - apply transl_condimm_int32u_correct; eauto with asmgen. -+ (* cmpl *) - exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmplu *) - exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. -+ (* cmplimm *) - exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpluimm *) - exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; 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 fn (cast32signed d s 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. Simpl. - + split. - * rewrite e. Simpl. - * intros. destruct r; Simpl. -- econstructor; split. - + apply exec_straight_one. simpl. eauto with asmgen. Simpl. - + split. - * Simpl. - * intros. destruct r; Simpl. -Qed. - -(* Translation of arithmetic operations *) - -Ltac SimplEval H := - match type of H with - | Some _ = None _ => discriminate - | Some _ = Some _ => inv H - | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) -end. - -Ltac TranslOpSimpl := - econstructor; split; - [ apply exec_straight_one; [simpl; eauto | reflexivity] - | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. - -Lemma transl_op_correct: - forall op args res k (rs: regset) m v c, - transl_op op args res k = OK c -> - eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef v rs'#(preg_of res) - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. -Proof. - assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } -Opaque Int.eq. - intros until c; intros TR EV. - unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -- (* Omove *) - destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. -- (* Oaddrsymbol *) - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). - exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. - intros (rs2 & A & B & C). - exists rs2; split. - apply exec_straight_step with rs1 m; auto. - split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). - rewrite Genv.shift_symbol_address. - replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). - exact B. - intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. -+ TranslOpSimpl. -- (* Oaddrstack *) - exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. auto with asmgen. -- (* Ocast8signed *) - econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. unfold getw. - 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. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. unfold getw. - 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 *) - clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; unfold getw; Simpl. -- (* Ocast32signed *) - exploit cast32signed_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. split. apply B. - intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } - apply C; auto. -- (* longofintu *) - econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. - split; intros; Simpl. unfold getl; unfold Pregmap.set; Simpl. destruct (PregEq.eq x0 x0). - + destruct (rs x0); auto. simpl. - assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. - rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. - + contradict n. auto. -- (* Ocmp *) - exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. -(* -- (* intconst *) - exploit loadimm32_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* longconst *) - exploit loadimm64_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* floatconst *) - destruct (Float.eq_dec n Float.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* singleconst *) - destruct (Float32.eq_dec n Float32.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* stackoffset *) - exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. auto with asmgen. -- (* addimm *) - exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* andimm *) - exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) - exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. - - - -- (* addlimm *) - exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. - -- (* andimm *) - exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) - exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* shrxlimm *) - clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. -*) -Qed. - - -(** Memory accesses *) - -Lemma indexed_memory_access_correct: - forall mk_instr base ofs k rs m, - base <> GPR31 -> - exists base' ofs' rs', - exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m - (mk_instr base' ofs' :: k) rs' m - /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - unfold indexed_memory_access; intros. - (* destruct Archi.ptr64 eqn:SF. *) - assert (Archi.ptr64 = true) as SF; auto. -- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. - destruct (make_immed64 (Ptrofs.to_int64 ofs)). -+ 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 -> instruction) rd m, - (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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 -> - base <> GPR31 -> rd <> PC -> - exists rs', - exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m - /\ rs'#rd = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. -Proof. - intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. - exploit indexed_memory_access_correct; eauto. - intros (base' & ofs' & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load. rewrite B, LOAD. eauto. Simpl. - split; intros; Simpl. -Qed. - -Lemma indexed_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) r1 m, - (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> - forall (base: ireg) ofs k (rs: regset) m', - Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> - exists rs', - exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. - exploit indexed_memory_access_correct; eauto. - intros (base' & ofs' & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. - intros; Simpl. -Qed. - -Lemma loadind_correct: - forall (base: ireg) ofs ty dst k c (rs: regset) m v, - loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - base <> GPR31 -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until v; intros TR LOAD NOT31. - assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs k - /\ forall base' ofs' rs', - exec_instr ge fn (mk_instr base' ofs') rs' m = - exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). - { unfold loadind in TR. - destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } - destruct A as (mk_instr & B & C). subst c. - eapply indexed_load_access_correct; eauto with asmgen. -Qed. - -Lemma storeind_correct: - forall (base: ireg) ofs ty src k c (rs: regset) m m', - storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - base <> GPR31 -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros until m'; intros TR STORE NOT31. - assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs k - /\ forall base' ofs' rs', - exec_instr ge fn (mk_instr base' ofs') rs' m = - exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). - { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } - destruct A as (mk_instr & B & C). subst c. - eapply indexed_store_access_correct; eauto with asmgen. -Qed. - - -Lemma Pget_correct: - forall (dst: gpreg) (src: preg) k (rs: regset) m, - src = RA -> - exists rs', - exec_straight ge fn (Pget dst src ::i k) rs m k rs' m - /\ rs'#dst = rs#src - /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. -Proof. - intros. econstructor; econstructor; econstructor. -- simpl. rewrite H. auto. -- Simpl. -- Simpl. -- intros. rewrite H. Simpl. -Qed. - -Lemma Pset_correct: - forall (dst: preg) (src: gpreg) k (rs: regset) m, - dst = RA -> - exists rs', - exec_straight ge fn (Pset dst src ::i k) rs m k rs' m - /\ rs'#dst = rs#src - /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. -Proof. - intros. econstructor; econstructor; econstructor; simpl. - rewrite H. auto. - Simpl. - Simpl. - intros. rewrite H. Simpl. -Qed. - -Lemma loadind_ptr_correct: - forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, - Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> - base <> GPR31 -> - exists rs', - exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m - /\ rs'#dst = v - /\ forall r, r <> PC -> r <> GPR31 -> 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 H1. auto. -Qed. - -Lemma storeind_ptr_correct: - forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', - Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - base <> GPR31 -> src <> GPR31 -> - exists rs', - exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true); auto. -Qed. - -Lemma transl_memory_access_correct: - forall mk_instr addr args k c (rs: regset) m v, - transl_memory_access mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - exists base ofs rs', - exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m - /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros until v; intros TR EV. - unfold transl_memory_access in TR; destruct addr; ArgsInv. -- (* indexed *) - inv EV. apply indexed_memory_access_correct; eauto with asmgen. -- (* global *) - simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. - constructor. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. unfold eval_offset. - assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). - { apply Val.offset_ptr_zero. } - remember (Genv.symbol_address ge i i0) as symbol. - destruct symbol; auto. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + simpl. rewrite Ptrofs.add_zero; auto. -- (* stack *) - inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. -Qed. - -Lemma transl_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c rd (rs: regset) m v v', - (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge 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' -> - rd <> PC -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. -Proof. - intros until v'; intros INSTR TR EV LOAD NOTPC. - exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. -Qed. - -Lemma transl_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c r1 (rs: regset) m v m', - (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> - r1 <> PC -> r1 <> GPR31 -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros until m'; intros INSTR TR EV STORE NOTPC NOT31. - exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. - intros; Simpl. -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 -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until v; intros TR EV LOAD. - assert (A: exists mk_instr, - transl_memory_access mk_instr addr args k = OK c - /\ forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). - { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } - destruct A as (mk_instr & B & C). - eapply transl_load_access_correct; eauto with asmgen. -Qed. - -Lemma transl_store_correct: - forall chunk addr args src k c (rs: regset) m a m', - transl_store chunk addr args src k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a rs#(preg_of src) = Some m' -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. -Proof. - intros until m'; intros TR EV STORE. - assert (A: exists mk_instr chunk', - transl_memory_access mk_instr addr args k = OK c - /\ (forall base ofs rs, - exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) - /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). - { unfold transl_store in TR; destruct chunk; ArgsInv; - (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). - destruct a; auto. apply Mem.store_signed_unsigned_8. - destruct a; auto. apply Mem.store_signed_unsigned_16. - } - destruct A as (mk_instr & chunk' & B & C & D). - rewrite D in STORE; clear D. - eapply transl_store_access_correct; eauto with asmgen. -Qed. - -Lemma make_epilogue_correct: - forall ge0 f m stk soff cs m' ms rs k tm, - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - agree ms (Vptr stk soff) rs -> - Mem.extends m tm -> - match_stack ge0 cs -> - exists rs', exists tm', - exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' - /\ agree ms (parent_sp cs) rs' - /\ Mem.extends m' tm' - /\ rs'#RA = parent_ra cs - /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). -Proof. - intros until tm; intros LP LRA FREE AG MEXT MCS. - exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). - exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). - exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. - exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. - exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). - unfold make_epilogue. - rewrite chunk_of_Tptr in *. - - exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 - ::i Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs tm). - - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - - congruence. - - intros (rs1 & A1 & B1 & C1). - assert (agree ms (Vptr stk soff) rs1) as AG1. - + destruct AG. - apply mkagree; auto. - rewrite C1; discriminate || auto. - intro. rewrite C1; auto; destruct r; simpl; try discriminate. - + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs1 tm). auto. - intros (rs2 & A2 & B2 & C2). - econstructor; econstructor; split. - * eapply exec_straight_trans. - { eexact A1. } - { eapply exec_straight_trans. - { eapply A2. } - { apply exec_straight_one. simpl. - rewrite (C2 GPR12) 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. - 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. - split. auto. - split. Simpl. rewrite B2. auto. - split. Simpl. - intros. Simpl. - rewrite C2; auto. -Qed. - -End CONSTRUCTORS. - - - diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v new file mode 100644 index 00000000..443e8757 --- /dev/null +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -0,0 +1,1099 @@ +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. +Require Import Conventions1. + +Module MB:=Machblock. +Module AB:=Asmblock. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +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. + +(* 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. + + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +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') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree 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 Mach.undef_regs_other; 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_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 -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (Asmblock.undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, Asmblock.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). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +(* NB: these two lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +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) -> + 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. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +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], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + 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 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +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). + all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H0. Simpl. discriminate. + destruct rs; try discriminate. inv H1. Simpl. + destruct rd; try discriminate. inv H1; Simpl. + auto. +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 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + 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 exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. auto. + simpl; auto. unfold nextblock; 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. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. \ No newline at end of file diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v new file mode 100644 index 00000000..dc8beb29 --- /dev/null +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -0,0 +1,322 @@ +(*** + +Auxiliary lemmas on starN and forward_simulation +in order to prove the forward simulation of Mach -> Machblock. + +***) + +Require Import Relations. +Require Import Wellfounded. +Require Import Coqlib. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. + + +Local Open Scope nat_scope. + + +(** Auxiliary lemma on starN *) +Section starN_lemma. + +Variable L: semantics. + +Local Hint Resolve starN_refl starN_step Eapp_assoc. + +Lemma starN_split n s t s': + starN (step L) (globalenv L) n s t s' -> + forall m k, n=m+k -> + exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. +Proof. + induction 1; simpl. + + intros m k H; assert (X: m=0); try omega. + assert (X0: k=0); try omega. + subst; repeat (eapply ex_intro); intuition eauto. + + intros m; destruct m as [| m']; simpl. + - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. + - intros k H2. inversion H2. + exploit (IHstarN m' k); eauto. intro. + destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). + repeat (eapply ex_intro). + instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). + intuition eauto. subst. auto. +Qed. + +Lemma starN_tailstep n s t1 s': + starN (step L) (globalenv L) n s t1 s' -> + forall (t t2:trace) s'', + Step L s' t2 s'' -> t = t1 ** t2 -> starN (step L) (globalenv L) (S n) s t s''. +Proof. + induction 1; simpl. + + intros t t1 s0; autorewrite with trace_rewrite. + intros; subst; eapply starN_step; eauto. + autorewrite with trace_rewrite; auto. + + intros. eapply starN_step; eauto. + intros; subst; autorewrite with trace_rewrite; auto. +Qed. + +End starN_lemma. + + + +(** General scheme from a "match_states" relation *) + +Section ForwardSimuBlock_REL. + +Variable L1 L2: semantics. + + +(** Hypothèses de la preuve *) + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Variable match_states: state L1 -> state L2 -> Prop. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 s2 r, final_state L1 s1 r -> match_states s1 s2 -> final_state L2 s2 r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> match_states s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states s1' s2'. + + +(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) + +Local Hint Resolve starN_refl starN_step. + +Definition follows_in_block (head current: state L1): Prop := + dist_end_block head >= dist_end_block current + /\ starN (step L1) (globalenv L1) (minus (dist_end_block head) (dist_end_block current)) head E0 current. + +Lemma follows_in_block_step (head previous next: state L1): + forall t, follows_in_block head previous -> Step L1 previous t next -> (dist_end_block previous)<>0 -> follows_in_block head next. +Proof. + intros t [H1 H2] H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)). + - eapply starN_tailstep; eauto. + - omega. +Qed. + +Lemma follows_in_block_init (head current: state L1): + forall t, Step L1 head t current -> (dist_end_block head)<>0 -> follows_in_block head current. +Proof. + intros t H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block current = 1). + - eapply starN_tailstep; eauto. + - omega. +Qed. + + +Record memostate := { + real: state L1; + memorized: option (state L1); + memo_star: forall head, memorized = Some head -> follows_in_block head real; + memo_final: forall r, final_state L1 real r -> memorized = None +}. + +Definition head (s: memostate): state L1 := + match memorized s with + | None => real s + | Some s' => s' + end. + +Lemma head_followed (s: memostate): follows_in_block (head s) (real s). +Proof. + destruct s as [rs ms Hs]. simpl. + destruct ms as [ms|]; unfold head; simpl; auto. + constructor 1. + omega. + cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O). + + apply starN_refl; auto. + + omega. +Qed. + +Inductive is_well_memorized (s s': memostate): Prop := + | StartBloc: + dist_end_block (real s) <> O -> + memorized s = None -> + memorized s' = Some (real s) -> + is_well_memorized s s' + | MidBloc: + dist_end_block (real s) <> O -> + memorized s <> None -> + memorized s' = memorized s -> + is_well_memorized s s' + | ExitBloc: + dist_end_block (real s) = O -> + memorized s' = None -> + is_well_memorized s s'. + +Local Hint Resolve StartBloc MidBloc ExitBloc. + +Definition memoL1 := {| + state := memostate; + genvtype := genvtype L1; + step := fun ge s t s' => + step L1 ge (real s) t (real s') + /\ is_well_memorized s s' ; + initial_state := fun s => initial_state L1 (real s) /\ memorized s = None; + final_state := fun s r => final_state L1 (real s) r; + globalenv:= globalenv L1; + symbolenv:= symbolenv L1 +|}. + + +(** Preuve des 2 forward simulations: L1 -> memoL1 et memoL1 -> L2 *) + +Lemma discr_dist_end s: + {dist_end_block s = O} + {dist_end_block s <> O}. +Proof. + destruct (dist_end_block s); simpl; intuition. +Qed. + +Lemma memo_simulation_step: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, s1 = (real s2) -> exists s2', Step memoL1 s2 t s2' /\ s1' = (real s2'). +Proof. + intros s1 t s1' H1 [rs2 ms2 Hmoi] H2. simpl in H2; subst. + destruct (discr_dist_end rs2) as [H3 | H3]. + + refine (ex_intro _ {|real:=s1'; memorized:=None |} _); simpl. + intuition. + + destruct ms2 as [s|]. + - refine (ex_intro _ {|real:=s1'; memorized:=Some s |} _); simpl. + intuition. + - refine (ex_intro _ {|real:=s1'; memorized:=Some rs2 |} _); simpl. + intuition. + Unshelve. + * intros; discriminate. + * intros; auto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_step; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_init; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. +Qed. + +Lemma forward_memo_simulation_1: forward_simulation L1 memoL1. +Proof. + apply forward_simulation_step with (match_states:=fun s1 s2 => s1 = (real s2)); auto. + + intros s1 H; eapply ex_intro with (x:={|real:=s1; memorized:=None |}); simpl. + intuition. + + intros; subst; auto. + + intros; exploit memo_simulation_step; eauto. + Unshelve. + * intros; discriminate. + * auto. +Qed. + +Lemma forward_memo_simulation_2: forward_simulation memoL1 L2. +Proof. + unfold memoL1; simpl. + apply forward_simulation_opt with (measure:=fun s => dist_end_block (real s)) (match_states:=fun s1 s2 => match_states (head s1) s2); simpl; auto. + + intros s1 [H0 H1]; destruct (match_initial_states (real s1) H0). + unfold head; rewrite H1. + intuition eauto. + + intros s1 s2 r X H0; unfold head in X. + erewrite memo_final in X; eauto. + + intros s1 t s1' [H1 H2] s2 H; subst. + destruct H2 as [ H0 H2 H3 | H0 H2 H3 | H0 H2]. + - (* StartBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H2 in H. rewrite H3. rewrite H4. intuition. + - (* MidBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H3. rewrite H4. intuition. + destruct (memorized s1); simpl; auto. tauto. + - (* EndBloc *) + constructor 1. + destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto. + * destruct (head_followed s1) as [H4 H3]. + cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega. + eapply starN_tailstep; eauto. + * unfold head; rewrite H2; simpl. intuition eauto. +Qed. + +Lemma forward_simulation_block_rel: forward_simulation L1 L2. +Proof. + eapply compose_forward_simulations. + eapply forward_memo_simulation_1. + apply forward_memo_simulation_2. +Qed. + + +End ForwardSimuBlock_REL. + + + +(* An instance of the previous scheme, when there is a translation from L1 states to L2 states + +Here, we do not require that the sequence of S2 states does exactly match the sequence of L1 states by trans_state. +This is because the exact matching is broken in Machblock on "goto" instruction (due to the find_label). + +However, the Machblock state after a goto remains "equivalent" to the trans_state of the Mach state in the sense of "equiv_on_next_step" below... + +*) + +Section ForwardSimuBlock_TRANS. + +Variable L1 L2: semantics. + +Variable trans_state: state L1 -> state L2. + +Definition equiv_on_next_step (P Q: Prop) s2_a s2_b: Prop := + (P -> (forall t s', Step L2 s2_a t s' <-> Step L2 s2_b t s')) /\ (Q -> (forall r, (final_state L2 s2_a r) <-> (final_state L2 s2_b r))). + +Definition match_states s1 s2: Prop := + equiv_on_next_step (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 (trans_state s1). + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + unfold match_states, equiv_on_next_step. intuition. +Qed. + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 r, final_state L1 s1 r -> final_state L2 (trans_state s1) r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1', starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> exists s2', Step L2 (trans_state s1) t s2' /\ match_states s1' s2'. + +Lemma forward_simulation_block_trans: forward_simulation L1 L2. +Proof. + eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states); try tauto. + + (* final_states *) intros s1 s2 r H1 [H2 H3]. rewrite H3; eauto. + + (* simu_end_block *) + intros s1 t s1' s2 H1 [H2a H2b]. exploit simu_end_block; eauto. + intros (s2' & H3 & H4); econstructor 1; intuition eauto. + rewrite H2a; auto. + inversion_clear H1. eauto. +Qed. + +End ForwardSimuBlock_TRANS. -- cgit From 3af2dc7aaa8c8139ddd26589258f2b289425f591 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 27 Nov 2018 15:34:34 +0100 Subject: Compiles for x86 and mppa_k1c (except Asmexpandaux.ml) --- mppa_k1c/Asmgenproof.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 74be571d..8eb0b693 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -160,3 +160,11 @@ End PRESERVATION. Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). +(*******************************************) +(* Stub actually needed by driver/Compiler *) + +Module Asmgenproof0. + +Definition return_address_offset := return_address_offset. + +End Asmgenproof0. \ No newline at end of file -- cgit From 09ebc4ffc4fa22e04e89f47d2f860cc831d6c23c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 28 Nov 2018 13:16:54 +0100 Subject: compilation Asmexpandaux both for x86/ and mppa_k1c/ --- mppa_k1c/Asm.v | 3 --- mppa_k1c/Asmaux.v | 5 +++++ 2 files changed, 5 insertions(+), 3 deletions(-) create mode 100644 mppa_k1c/Asmaux.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index c142185c..17cd67f4 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -291,9 +291,6 @@ Fixpoint unfold (lb: bblocks) := Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; correct: unfold fn_blocks = fn_code }. -(* For OCaml code *) -Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. - Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. Definition genv := Genv.t fundef unit. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v new file mode 100644 index 00000000..85359658 --- /dev/null +++ b/mppa_k1c/Asmaux.v @@ -0,0 +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 |}. -- cgit From 5568558f61a13754cc9f80d5e9641c6e9e9bc742 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 28 Nov 2018 14:24:01 +0100 Subject: mppa_k1c compiles --- mppa_k1c/Asmexpand.ml | 5 ++--- mppa_k1c/Asmgen.v | 7 +------ 2 files changed, 3 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 45fe9b32..0fcc1212 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -20,7 +20,6 @@ of the RISC-V assembly code. *) open Asm -open Asmgen open Asmexpandaux open AST open Camlcoq @@ -48,9 +47,9 @@ let align n a = (n + a - 1) land (-a) List.iter emit (Asmgen.loadimm32 dst n []) *) let expand_addptrofs dst src n = - List.iter emit (addptrofs dst src n :: []) + List.iter emit (basic_to_instruction (Asmblock.PArith (Asmblockgen.addptrofs dst src n)) :: []) let expand_storeind_ptr src base ofs = - List.iter emit (storeind_ptr src base ofs :: []) + List.iter emit (basic_to_instruction (Asmblockgen.storeind_ptr src base ofs) :: []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 9b9e6272..6f61747f 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -21,11 +21,6 @@ Require Import Errors. Local Open Scope error_monad_scope. -(** For OCaml code *) -Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n). -Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := - basic_to_instruction (storeind_ptr src base ofs). - Definition transf_program (p: Mach.program) : res Asm.program := let mbp := Machblockgen.transf_program p in do abp <- Asmblockgen.transf_program mbp; @@ -40,4 +35,4 @@ Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruc let mbf := Machblockgen.transf_function f in let mbc := Machblockgen.trans_code l in do abc <- transl_blocks mbf mbc true; - OK (unfold abc). \ No newline at end of file + OK (unfold abc). -- cgit From 30e8e1618e59bdb585b1fb36cddce41eefe12364 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 28 Nov 2018 17:31:46 +0100 Subject: Wrote some tests on va_arg, need to implement __compcert_va_int32 & cie --- mppa_k1c/Asmexpand.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 0fcc1212..07b15a63 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -340,14 +340,13 @@ let save_arguments first_reg base_ofs = let open Asmblock in let vararg_start_ofs : Z.t option ref = ref None -let expand_builtin_va_start r = assert false -(*match !vararg_start_ofs with +let expand_builtin_va_start r = (* assert false *) +match !vararg_start_ofs with | None -> invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> - expand_addptrofs X31 X2 (Ptrofs.repr ofs); - expand_storeind_ptr X31 r Ptrofs.zero -*) + expand_addptrofs Asmblock.GPR32 Asmblock.GPR12 (Ptrofs.repr ofs); + expand_storeind_ptr Asmblock.GPR32 r Ptrofs.zero (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to two instructions, one computing the low 32 bits of the result, -- cgit From 79a2dac7e5317e515ce9610db1d48d0fc9ff0708 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Nov 2018 17:31:11 +0100 Subject: Finished implementation of va_arg + testing done --- mppa_k1c/Asmexpand.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 07b15a63..3209163f 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -330,8 +330,11 @@ let rec args_size sz = function let arguments_size sg = args_size 0 sg.sig_args +let _nbregargs_ = 12 +let _alignment_ = 8 + let save_arguments first_reg base_ofs = let open Asmblock in - for i = first_reg to 7 do + for i = first_reg to (_nbregargs_ - 1) do expand_storeind_ptr int_param_regs.(i) GPR12 @@ -442,12 +445,13 @@ let expand_instruction instr = emit (Pmv (Asmblock.GPR14, Asmblock.GPR12)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in - let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in + let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; let va_ofs = - Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in + sz in + (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin @@ -460,7 +464,7 @@ let expand_instruction instr = let extra_sz = if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in - if n >= 8 then 0 else align 16 ((8 - n) * wordsize) + if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) end else 0 in expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) -- cgit From 13e381fae01360f25bd01cb95b470ead906748e1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 3 Dec 2018 11:20:59 +0100 Subject: Introducing ;; as Pcomma in Asm.v --- mppa_k1c/Asm.v | 3 +- mppa_k1c/TargetPrinter.ml | 129 +++++++++++++++++++++++----------------------- 2 files changed, 67 insertions(+), 65 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 17cd67f4..520bc453 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -47,6 +47,7 @@ Inductive instruction : Type := | 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 *) @@ -280,7 +281,7 @@ Definition unfold_exit (oc: option control) := | Some c => control_to_instruction c :: nil end. -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ unfold_body (body b) ++ unfold_exit (exit b). +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ unfold_body (body b) ++ unfold_exit (exit b) ++ Psemi :: nil. Fixpoint unfold (lb: bblocks) := match lb with diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 143b7622..4f67ea65 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -127,9 +127,9 @@ module Target : TARGET = let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); - fprintf oc " make %a = %s\n;;\n" ireg r (extern_atom id) + fprintf oc " make %a = %s\n" ireg r (extern_atom id) end else begin - fprintf oc " make %a = %a\n;;\n" ireg r symbol_offset (id, ofs) + fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) end (* Emit .file / .loc debugging directives *) @@ -221,152 +221,153 @@ module Target : TARGET = | _ -> assert false end - | Pnop -> fprintf oc " nop\n;;\n" + | Pnop -> fprintf oc " nop\n" + | Psemi -> fprintf oc ";;\n" - | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs - | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Control flow instructions *) | Pget (rd, rs) -> - fprintf oc " get %a = %a\n;;\n" ireg rd preg rs + fprintf oc " get %a = %a\n" ireg rd preg rs | Pset (rd, rs) -> - fprintf oc " set %a = %a\n;;\n" preg rd ireg rs + fprintf oc " set %a = %a\n" preg rd ireg rs | Pret -> - fprintf oc " ret \n;;\n" + fprintf oc " ret \n" | Pcall(s) -> - fprintf oc " call %a\n;;\n" symbol s + fprintf oc " call %a\n" symbol s | Pgoto(s) -> - fprintf oc " goto %a\n;;\n" symbol s + fprintf oc " goto %a\n" symbol s | Pj_l(s) -> - fprintf oc " goto %a\n;;\n" print_label s + fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + fprintf oc " cb.%a %a?%a\n" bcond bt ireg r print_label lbl (* Load/Store instructions *) | Plb(rd, ra, ofs) -> - fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plbu(rd, ra, ofs) -> - fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lbz %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plh(rd, ra, ofs) -> - fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lhs %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plhu(rd, ra, ofs) -> - fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lhz %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " ld %a = %a[%a]\n" ireg rd offset ofs ireg ra | Psb(rd, ra, ofs) -> - fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sb %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psh(rd, ra, ofs) -> - fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sh %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd (* Arith R instructions *) | Pcvtw2l(rd) -> assert false (* Arith RR instructions *) | Pmv(rd, rs) | Pmvw2l(rd, rs) -> - fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs + fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs | Pcvtl2w(rd, rs) -> assert false | Pnegl(rd, rs) -> assert Archi.ptr64; - fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs + fprintf oc " negd %a = %a\n" ireg rd ireg rs | Pnegw(rd, rs) -> - fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs + fprintf oc " negw %a = %a\n" ireg rd ireg rs | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd + fprintf oc " fnegd %a = %a\n" ireg rs ireg rd (* Arith RI32 instructions *) | Pmake (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm + fprintf oc " make %a, %a\n" ireg rd coqint imm (* Arith RI64 instructions *) | Pmakel (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm + fprintf oc " make %a, %a\n" ireg rd coqint64 imm (* Arith RRR instructions *) | Pcompw (it, rd, rs1, rs2) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompl (it, rd, rs1, rs2) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 | Paddw (rd, rs1, rs2) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pmulw (rd, rs1, rs2) -> - fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porw (rd, rs1, rs2) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psllw (rd, rs1, rs2) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> - fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmull (rd, rs1, rs2) -> - fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pslll (rd, rs1, rs2) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrll (rd, rs1, rs2) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psral (rd, rs1, rs2) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm | Paddiw (rd, rs, imm) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psraiw (rd, rs, imm) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psllil (rd, rs, imm) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrail (rd, rs, imm) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm (* Arith RRI64 instructions *) | Pcompil (it, rd, rs, imm) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + 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;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = -- cgit From 03b20488fd4202970ed307dbec696cc0e64b8f31 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 3 Dec 2018 18:01:56 +0100 Subject: Tout début de développement d'un postpass Asmblock en Coq MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassScheduling.v | 38 +++++++++++++++ mppa_k1c/PostpassSchedulingProof.v | 97 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+) create mode 100644 mppa_k1c/PostpassScheduling.v create mode 100644 mppa_k1c/PostpassSchedulingProof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v new file mode 100644 index 00000000..8ec72f90 --- /dev/null +++ b/mppa_k1c/PostpassScheduling.v @@ -0,0 +1,38 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Asmblock. + +(** Oracle taking as input a basic block, + returns a basic block with its instruction reordered *) +Axiom schedule: bblock -> bblock. + +(** Oracle taking as input a basic block + splits it into several bblocks (representing bundles *) +Axiom split: bblock -> list bblock. + +(* TODO - separate the postpass_schedule in two phases *) + +Definition postpass_schedule (lb : list bblock) : list bblock := + match lb with + | nil => nil + | (cons b lb) => split (schedule b) ++ lb + end. + +Definition transf_function (f: function) : function := + mkfunction (fn_sig f) (postpass_schedule (fn_blocks f)). + +Definition transf_fundef (f: fundef) : fundef := + AST.transf_fundef transf_function f. + +Definition transf_program (p: program) : program := + AST.transform_program transf_fundef p. \ No newline at end of file diff --git a/mppa_k1c/PostpassSchedulingProof.v b/mppa_k1c/PostpassSchedulingProof.v new file mode 100644 index 00000000..3e3201bb --- /dev/null +++ b/mppa_k1c/PostpassSchedulingProof.v @@ -0,0 +1,97 @@ +(* *********************************************************************) +(* *) +(* 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 the [Debugvar] pass. *) + +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 PostpassScheduling. + +(** * Relational characterization of the transformation *) + +Definition match_prog (p tp: Asmblock.program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (Genv.find_funct_transf TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s1 s2, s1 = s2 -> match_states s1 s2. + +(** TODO - continue *) + +(* Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + econstructor; split. + eapply initial_state_intro with (m0 := m0). + eapply (Genv.init_mem_transf TRANSL); eauto. +(* rewrite (match_program_main TRANSL), symbols_preserved; eauto. + apply function_ptr_translated; auto. + rewrite sig_function_translated. auto. *) + constructor; auto. constructor. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. inv H5. econstructor; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (Linear.semantics prog) (Linear.semantics tprog). +Proof. + eapply forward_simulation_opt. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. +Qed. + *) +End PRESERVATION. -- cgit From 8c5e82fdd011d68e7dcba3adb88d6b5036e47958 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 4 Dec 2018 17:57:04 +0100 Subject: Added definitions and proof sketch for PostpassScheduling --- mppa_k1c/PostpassScheduling.v | 34 ++++++----- mppa_k1c/PostpassSchedulingProof.v | 116 +++++++++++++++++++++++++++++-------- 2 files changed, 110 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 8ec72f90..381e1214 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -10,29 +10,33 @@ (* *) (* *********************************************************************) +Require Import Coqlib Errors AST. Require Import Asmblock. +Local Open Scope error_monad_scope. + (** Oracle taking as input a basic block, - returns a basic block with its instruction reordered *) + returns a basic block with its instructions reordered *) Axiom schedule: bblock -> bblock. -(** Oracle taking as input a basic block - splits it into several bblocks (representing bundles *) -Axiom split: bblock -> list bblock. - -(* TODO - separate the postpass_schedule in two phases *) +(* TODO - implement the verificator *) +Definition transf_block (b : bblock) : res bblock := OK (schedule b). -Definition postpass_schedule (lb : list bblock) : list bblock := +Fixpoint transf_blocks (lb : list bblock) : res (list bblock) := match lb with - | nil => nil - | (cons b lb) => split (schedule b) ++ lb + | nil => OK nil + | (cons b lb) => + do lb' <- transf_blocks lb; + do b' <- transf_block b; + OK (b' :: lb') end. -Definition transf_function (f: function) : function := - mkfunction (fn_sig f) (postpass_schedule (fn_blocks f)). +Definition transf_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); + OK (mkfunction (fn_sig f) lb). -Definition transf_fundef (f: fundef) : fundef := - AST.transf_fundef transf_function f. +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. -Definition transf_program (p: program) : program := - AST.transform_program transf_fundef p. \ No newline at end of file +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. \ No newline at end of file diff --git a/mppa_k1c/PostpassSchedulingProof.v b/mppa_k1c/PostpassSchedulingProof.v index 3e3201bb..4f85444f 100644 --- a/mppa_k1c/PostpassSchedulingProof.v +++ b/mppa_k1c/PostpassSchedulingProof.v @@ -21,14 +21,24 @@ Require Import PostpassScheduling. (** * Relational characterization of the transformation *) Definition match_prog (p tp: Asmblock.program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: - forall p, match_prog p (transf_program p). + forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. - intros. eapply match_transform_program; eauto. + intros. eapply match_transform_partial_program; eauto. Qed. +Inductive transf_block_spec (ge: Genv.t fundef unit) (f: function) (bb tbb: bblock) := + | transf_block_spec_intro: + (forall rs m, + exec_bblock ge f bb rs m = exec_bblock ge f tbb rs m) -> + transf_block_spec ge f bb tbb. + +Axiom transf_block_inv: + forall ge f bb tbb, + transf_block bb = OK tbb -> transf_block_spec ge f bb tbb. + Section PRESERVATION. Variables prog tprog: program. @@ -39,59 +49,115 @@ Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_transf TRANSL). +Proof (Genv.find_symbol_match TRANSL). Lemma senv_preserved: Senv.equiv ge tge. -Proof (Genv.senv_transf TRANSL). +Proof (Genv.senv_match TRANSL). Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). -Proof (Genv.find_funct_transf TRANSL). + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial TRANSL). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> - Genv.find_funct_ptr tge v = Some (transf_fundef f). -Proof (Genv.find_funct_ptr_transf TRANSL). + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSL). + +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 function_ptr_translated; eauto. + intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. +Qed. Inductive match_states: state -> state -> Prop := | match_states_intro: forall s1 s2, s1 = s2 -> match_states s1 s2. -(** TODO - continue *) +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSL). + +Lemma prog_main_address_preserved: + (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = + (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). +Proof. + unfold Genv.symbol_address. rewrite symbols_preserved. + rewrite prog_main_preserved. auto. +Qed. -(* Lemma transf_initial_states: +Lemma transf_initial_states: forall st1, initial_state prog st1 -> exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inv H. econstructor; split. - eapply initial_state_intro with (m0 := m0). - eapply (Genv.init_mem_transf TRANSL); eauto. -(* rewrite (match_program_main TRANSL), symbols_preserved; eauto. - apply function_ptr_translated; auto. - rewrite sig_function_translated. auto. *) - constructor; auto. constructor. + - eapply initial_state_intro. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. Qed. Lemma transf_final_states: forall st1 st2 r, match_states st1 st2 -> final_state st1 r -> final_state st2 r. Proof. - intros. inv H0. inv H. inv H5. econstructor; eauto. + intros. inv H0. inv H. econstructor; eauto. Qed. +Lemma transf_find_bblock: + forall ofs f bb tf, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + transf_function f = OK tf -> + exists tbb, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks tf) = Some tbb + /\ transf_block bb = OK tbb. +Proof. +Admitted. + +Lemma transf_exec_bblock: + forall f tf bb rs m rs' m', + exec_bblock ge f bb rs m = Next rs' m' -> + transf_function f = OK tf -> + exec_bblock tge tf bb rs m = Next rs' m'. +Proof. +Admitted. + +Axiom TODO: False. + +Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', step tge s1' t s2' /\ match_states s2 s2'). +Proof. + induction 1; intros; inv MS. + - exploit function_ptr_translated; eauto. intros (tf & A & B). monadInv B. + exploit transf_find_bblock; eauto. intros (tbb & C & D). + exists (State rs' m'); split; try (constructor; auto). + econstructor; eauto. + exploit transf_block_inv; eauto. intros E. inv E. + erewrite <- H3. + eapply transf_exec_bblock; eauto. + - destruct TODO. + - destruct TODO. +Admitted. + Theorem transf_program_correct: - forward_simulation (Linear.semantics prog) (Linear.semantics tprog). + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). Proof. - eapply forward_simulation_opt. - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - eexact transf_step_correct. + eapply forward_simulation_step. + - apply senv_preserved. + - apply transf_initial_states. + - apply transf_final_states. + - apply transf_step_correct. Qed. - *) + End PRESERVATION. -- cgit From 2f6669a13e43b0b35ecd0a8d745f5c29bae7785c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Dec 2018 16:34:04 +0100 Subject: Renaming PostpassSchedulingProof -> PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingProof.v | 163 ------------------------------------- mppa_k1c/PostpassSchedulingproof.v | 163 +++++++++++++++++++++++++++++++++++++ 2 files changed, 163 insertions(+), 163 deletions(-) delete mode 100644 mppa_k1c/PostpassSchedulingProof.v create mode 100644 mppa_k1c/PostpassSchedulingproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingProof.v b/mppa_k1c/PostpassSchedulingProof.v deleted file mode 100644 index 4f85444f..00000000 --- a/mppa_k1c/PostpassSchedulingProof.v +++ /dev/null @@ -1,163 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for the [Debugvar] pass. *) - -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 PostpassScheduling. - -(** * Relational characterization of the transformation *) - -Definition match_prog (p tp: Asmblock.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. - -Inductive transf_block_spec (ge: Genv.t fundef unit) (f: function) (bb tbb: bblock) := - | transf_block_spec_intro: - (forall rs m, - exec_bblock ge f bb rs m = exec_bblock ge f tbb rs m) -> - transf_block_spec ge f bb tbb. - -Axiom transf_block_inv: - forall ge f bb tbb, - transf_block bb = OK tbb -> transf_block_spec ge f bb tbb. - -Section PRESERVATION. - -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall id, - Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_match TRANSL). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSL). - -Lemma functions_translated: - forall v f, - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial TRANSL). - -Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> - exists tf, - Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSL). - -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 function_ptr_translated; eauto. - intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. -Qed. - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall s1 s2, s1 = s2 -> match_states s1 s2. - -Lemma prog_main_preserved: - prog_main tprog = prog_main prog. -Proof (match_program_main TRANSL). - -Lemma prog_main_address_preserved: - (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = - (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). -Proof. - unfold Genv.symbol_address. rewrite symbols_preserved. - rewrite prog_main_preserved. auto. -Qed. - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> - exists st2, initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inv H. - econstructor; split. - - eapply initial_state_intro. - eapply (Genv.init_mem_transf_partial TRANSL); eauto. - - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> final_state st1 r -> final_state st2 r. -Proof. - intros. inv H0. inv H. econstructor; eauto. -Qed. - -Lemma transf_find_bblock: - forall ofs f bb tf, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> - transf_function f = OK tf -> - exists tbb, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks tf) = Some tbb - /\ transf_block bb = OK tbb. -Proof. -Admitted. - -Lemma transf_exec_bblock: - forall f tf bb rs m rs' m', - exec_bblock ge f bb rs m = Next rs' m' -> - transf_function f = OK tf -> - exec_bblock tge tf bb rs m = Next rs' m'. -Proof. -Admitted. - -Axiom TODO: False. - -Theorem transf_step_correct: - forall s1 t s2, step ge s1 t s2 -> - forall s1' (MS: match_states s1 s1'), - (exists s2', step tge s1' t s2' /\ match_states s2 s2'). -Proof. - induction 1; intros; inv MS. - - exploit function_ptr_translated; eauto. intros (tf & A & B). monadInv B. - exploit transf_find_bblock; eauto. intros (tbb & C & D). - exists (State rs' m'); split; try (constructor; auto). - econstructor; eauto. - exploit transf_block_inv; eauto. intros E. inv E. - erewrite <- H3. - eapply transf_exec_bblock; eauto. - - destruct TODO. - - destruct TODO. -Admitted. - -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_step. - - apply senv_preserved. - - apply transf_initial_states. - - apply transf_final_states. - - apply transf_step_correct. -Qed. - -End PRESERVATION. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v new file mode 100644 index 00000000..4f85444f --- /dev/null +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -0,0 +1,163 @@ +(* *********************************************************************) +(* *) +(* 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 the [Debugvar] pass. *) + +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 PostpassScheduling. + +(** * Relational characterization of the transformation *) + +Definition match_prog (p tp: Asmblock.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. + +Inductive transf_block_spec (ge: Genv.t fundef unit) (f: function) (bb tbb: bblock) := + | transf_block_spec_intro: + (forall rs m, + exec_bblock ge f bb rs m = exec_bblock ge f tbb rs m) -> + transf_block_spec ge f bb tbb. + +Axiom transf_block_inv: + forall ge f bb tbb, + transf_block bb = OK tbb -> transf_block_spec ge f bb tbb. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_match TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSL). + +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 function_ptr_translated; eauto. + intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. +Qed. + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s1 s2, s1 = s2 -> match_states s1 s2. + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSL). + +Lemma prog_main_address_preserved: + (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = + (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). +Proof. + unfold Genv.symbol_address. rewrite symbols_preserved. + rewrite prog_main_preserved. auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + econstructor; split. + - eapply initial_state_intro. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. econstructor; eauto. +Qed. + +Lemma transf_find_bblock: + forall ofs f bb tf, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + transf_function f = OK tf -> + exists tbb, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks tf) = Some tbb + /\ transf_block bb = OK tbb. +Proof. +Admitted. + +Lemma transf_exec_bblock: + forall f tf bb rs m rs' m', + exec_bblock ge f bb rs m = Next rs' m' -> + transf_function f = OK tf -> + exec_bblock tge tf bb rs m = Next rs' m'. +Proof. +Admitted. + +Axiom TODO: False. + +Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', step tge s1' t s2' /\ match_states s2 s2'). +Proof. + induction 1; intros; inv MS. + - exploit function_ptr_translated; eauto. intros (tf & A & B). monadInv B. + exploit transf_find_bblock; eauto. intros (tbb & C & D). + exists (State rs' m'); split; try (constructor; auto). + econstructor; eauto. + exploit transf_block_inv; eauto. intros E. inv E. + erewrite <- H3. + eapply transf_exec_bblock; eauto. + - destruct TODO. + - destruct TODO. +Admitted. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_step. + - apply senv_preserved. + - apply transf_initial_states. + - apply transf_final_states. + - apply transf_step_correct. +Qed. + +End PRESERVATION. -- cgit From f136beaf95fda574f120619b0d6b2dba46072032 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Dec 2018 16:34:49 +0100 Subject: Moving size_blocks from Asmblockgen to Asmblock --- mppa_k1c/Asmblock.v | 8 ++++++++ mppa_k1c/Asmblockgen.v | 9 --------- 2 files changed, 8 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 1040d4c0..912a02d5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -492,6 +492,14 @@ Proof. Definition bblocks := list bblock. +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 8bcbc712..a4d0526d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -924,21 +924,12 @@ Definition transl_function (f: Machblock.function) := Pget GPRA RA ::b storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb)). -Fixpoint size_blocks (l: bblocks): Z := - match l with - | nil => 0 - | b :: l => - (size b) + (size_blocks l) - end - . - Definition transf_function (f: Machblock.function) : res Asmblock.function := do tf <- transl_function f; if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) then Error (msg "code size exceeded") else OK tf. - Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := transf_partial_fundef transf_function f. -- cgit From f9de154cde1974a8fa9afec9ad83653384ec912f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Dec 2018 16:35:17 +0100 Subject: Generalizing PostpassScheduling to include bblock splitting --- mppa_k1c/Asmblock.v | 12 +++-- mppa_k1c/PostpassScheduling.v | 30 +++++++----- mppa_k1c/PostpassSchedulingproof.v | 97 ++++++++++++++++++++++++++++---------- 3 files changed, 98 insertions(+), 41 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 912a02d5..c11d043b 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -403,12 +403,16 @@ Definition non_empty_bblockb (body: list basic) (exit: option control): bool := Lemma non_empty_bblock_refl: forall body exit, - non_empty_bblock body exit -> + non_empty_bblock body exit <-> Is_true (non_empty_bblockb body exit). Proof. - intros. destruct body; destruct exit. - all: simpl; auto. - inv H; contradiction. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. intros. inversion H; contradiction. + - destruct body; destruct exit. + all: simpl; auto. + all: intros; try (right; discriminate); try (left; discriminate). + contradiction. Qed. (* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 381e1214..5232f903 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -10,31 +10,37 @@ (* *) (* *********************************************************************) -Require Import Coqlib Errors AST. +Require Import Coqlib Errors AST Integers. Require Import Asmblock. Local Open Scope error_monad_scope. (** Oracle taking as input a basic block, - returns a basic block with its instructions reordered *) -Axiom schedule: bblock -> bblock. + returns a schedule expressed as a list of bundles *) +Axiom schedule: bblock -> list bblock. (* TODO - implement the verificator *) -Definition transf_block (b : bblock) : res bblock := OK (schedule b). +Definition verified_schedule (bb : bblock) : res (list bblock) := OK (schedule bb). -Fixpoint transf_blocks (lb : list bblock) : res (list bblock) := - match lb with +Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := + match lbb with | nil => OK nil - | (cons b lb) => - do lb' <- transf_blocks lb; - do b' <- transf_block b; - OK (b' :: lb') + | (cons bb lbb) => + do tlbb <- transf_blocks lbb; + do tbb <- verified_schedule bb; + OK (tbb ++ tlbb) end. -Definition transf_function (f: function) : res function := - do lb <- transf_blocks (fn_blocks f); +Definition transl_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); OK (mkfunction (fn_sig f) lb). +Definition transf_function (f: function) : res function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + Definition transf_fundef (f: fundef) : res fundef := transf_partial_fundef transf_function f. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 4f85444f..294ff0a1 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -10,15 +10,14 @@ (* *) (* *********************************************************************) -(** Correctness proof for the [Debugvar] pass. *) - 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 PostpassScheduling. -(** * Relational characterization of the transformation *) +Local Open Scope error_monad_scope. Definition match_prog (p tp: Asmblock.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. @@ -29,15 +28,60 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Inductive transf_block_spec (ge: Genv.t fundef unit) (f: function) (bb tbb: bblock) := - | transf_block_spec_intro: +Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + | bblock_equiv_intro: (forall rs m, - exec_bblock ge f bb rs m = exec_bblock ge f tbb rs m) -> - transf_block_spec ge f bb tbb. + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> + bblock_equiv ge f bb bb'. + +Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. +Proof. + intros. destruct l; simpl. + - contradiction. + - discriminate. +Qed. + +Program Definition concat2 (bb bb': bblock) : res bblock := + match (exit bb) with + | None => + match (header bb') with + | nil => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + | _ => Error (msg "PostpassSchedulingproof.concat2") + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end. +Next Obligation. + apply non_empty_bblock_refl. + destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']. simpl in *. + apply non_empty_bblock_refl in COR. apply non_empty_bblock_refl in COR'. + inv COR. + - left. apply app_nonil. auto. + - contradiction. +Qed. -Axiom transf_block_inv: - forall ge f bb tbb, - transf_block bb = OK tbb -> transf_block_spec ge f bb tbb. +Fixpoint concat_all (lbb: list bblock) : res bblock := + match lbb with + | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") + | bb::nil => OK bb + | bb::lbb => + do bb' <- concat_all lbb; + concat2 bb bb' + end. + +Axiom verified_schedule_correct: + forall ge f bb lbb, + verified_schedule bb = OK lbb -> + exists tbb, + concat_all lbb = OK tbb + /\ bblock_equiv ge f bb tbb. + +Theorem concat_exec_straight (ge: Genv.t fundef unit) (f: function) : + forall lbb bb rs m rs' m' c, + concat_all lbb = OK bb -> + exec_bblock ge f bb rs m = Next rs' m' -> + exec_straight_blocks ge f (lbb++c) rs m c rs' m'. +Proof. +Admitted. Section PRESERVATION. @@ -117,17 +161,16 @@ Lemma transf_find_bblock: forall ofs f bb tf, find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> transf_function f = OK tf -> - exists tbb, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks tf) = Some tbb - /\ transf_block bb = OK tbb. + exists lbb, + verified_schedule bb = OK lbb + /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). Proof. Admitted. Lemma transf_exec_bblock: - forall f tf bb rs m rs' m', - exec_bblock ge f bb rs m = Next rs' m' -> + forall f tf bb rs m, transf_function f = OK tf -> - exec_bblock tge tf bb rs m = Next rs' m'. + exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. Proof. Admitted. @@ -136,16 +179,20 @@ Axiom TODO: False. Theorem transf_step_correct: forall s1 t s2, step ge s1 t s2 -> forall s1' (MS: match_states s1 s1'), - (exists s2', step tge s1' t s2' /\ match_states s2 s2'). + (exists s2', plus step tge s1' t s2' /\ match_states s2 s2'). Proof. induction 1; intros; inv MS. - - exploit function_ptr_translated; eauto. intros (tf & A & B). monadInv B. - exploit transf_find_bblock; eauto. intros (tbb & C & D). - exists (State rs' m'); split; try (constructor; auto). - econstructor; eauto. - exploit transf_block_inv; eauto. intros E. inv E. - erewrite <- H3. - eapply transf_exec_bblock; eauto. + - 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). + erewrite transf_exec_bblock in H2; eauto. + exploit concat_exec_straight; eauto. + { inv BBEQ. erewrite <- H3. eauto. } + intros ESB. + eexists. split. + + eapply exec_straight_steps_1; eauto. + monadInv EQ. destruct (zlt _ _). discriminate. monadInv EQ1. omega. + + econstructor; eauto. - destruct TODO. - destruct TODO. Admitted. @@ -153,7 +200,7 @@ Admitted. Theorem transf_program_correct: forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). Proof. - eapply forward_simulation_step. + eapply forward_simulation_plus. - apply senv_preserved. - apply transf_initial_states. - apply transf_final_states. -- cgit From a8398e8909add27e55c5d196ab280557622584d7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 7 Dec 2018 16:41:50 +0100 Subject: Fixed bundles (back to 1 instruction per bundle) --- mppa_k1c/TargetPrinter.ml | 130 +++++++++++++++++++++++----------------------- 1 file changed, 65 insertions(+), 65 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4f67ea65..4aafc13f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -127,9 +127,9 @@ module Target : TARGET = let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); - fprintf oc " make %a = %s\n" ireg r (extern_atom id) + fprintf oc " make %a = %s\n;;\n" ireg r (extern_atom id) end else begin - fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) + fprintf oc " make %a = %a\n;;\n" ireg r symbol_offset (id, ofs) end (* Emit .file / .loc debugging directives *) @@ -221,153 +221,153 @@ module Target : TARGET = | _ -> assert false end - | Pnop -> fprintf oc " nop\n" - | Psemi -> fprintf oc ";;\n" + | Pnop -> fprintf oc " nop\n;;\n" + | Psemi -> fprintf oc "" - | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs - | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 (* Control flow instructions *) | Pget (rd, rs) -> - fprintf oc " get %a = %a\n" ireg rd preg rs + fprintf oc " get %a = %a\n;;\n" ireg rd preg rs | Pset (rd, rs) -> - fprintf oc " set %a = %a\n" preg rd ireg rs + fprintf oc " set %a = %a\n;;\n" preg rd ireg rs | Pret -> - fprintf oc " ret \n" + fprintf oc " ret \n;;\n" | Pcall(s) -> - fprintf oc " call %a\n" symbol s + fprintf oc " call %a\n;;\n" symbol s | Pgoto(s) -> - fprintf oc " goto %a\n" symbol s + fprintf oc " goto %a\n;;\n" symbol s | Pj_l(s) -> - fprintf oc " goto %a\n" print_label s + fprintf oc " goto %a\n;;\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a?%a\n" bcond bt ireg r print_label lbl + fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl (* Load/Store instructions *) | Plb(rd, ra, ofs) -> - fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plbu(rd, ra, ofs) -> - fprintf oc " lbz %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plh(rd, ra, ofs) -> - fprintf oc " lhs %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plhu(rd, ra, ofs) -> - fprintf oc " lhz %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a = %a[%a]\n" ireg rd offset ofs ireg ra + fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra | Psb(rd, ra, ofs) -> - fprintf oc " sb %a[%a] = %a\n" offset ofs ireg ra ireg rd + fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psh(rd, ra, ofs) -> - fprintf oc " sh %a[%a] = %a\n" offset ofs ireg ra ireg rd + fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd + fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd + fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd (* Arith R instructions *) | Pcvtw2l(rd) -> assert false (* Arith RR instructions *) | Pmv(rd, rs) | Pmvw2l(rd, rs) -> - fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs + fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs | Pcvtl2w(rd, rs) -> assert false | Pnegl(rd, rs) -> assert Archi.ptr64; - fprintf oc " negd %a = %a\n" ireg rd ireg rs + fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs | Pnegw(rd, rs) -> - fprintf oc " negw %a = %a\n" ireg rd ireg rs + fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n" ireg rs ireg rd + fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd (* Arith RI32 instructions *) | Pmake (rd, imm) -> - fprintf oc " make %a, %a\n" ireg rd coqint imm + fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm (* Arith RI64 instructions *) | Pmakel (rd, imm) -> - fprintf oc " make %a, %a\n" ireg rd coqint64 imm + fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm (* Arith RRR instructions *) | Pcompw (it, rd, rs1, rs2) -> - fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompl (it, rd, rs1, rs2) -> - fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 | Paddw (rd, rs1, rs2) -> - fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 | Pmulw (rd, rs1, rs2) -> - fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> - fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Porw (rd, rs1, rs2) -> - fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> - fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> - fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> - fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psllw (rd, rs1, rs2) -> - fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> - fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Porl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pmull (rd, rs1, rs2) -> - fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Pslll (rd, rs1, rs2) -> - fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psrll (rd, rs1, rs2) -> - fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 | Psral (rd, rs1, rs2) -> - fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> - fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm | Paddiw (rd, rs, imm) -> - fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psraiw (rd, rs, imm) -> - fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psllil (rd, rs, imm) -> - fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> - fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Psrail (rd, rs, imm) -> - fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm (* Arith RRI64 instructions *) | Pcompil (it, rd, rs, imm) -> - fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm + fprintf oc " compd.%a %a = %a, %a\n;;\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 + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = -- cgit From 7ae2c448ca5c318a3b752293792e7912379183a5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 7 Dec 2018 16:42:31 +0100 Subject: Fixed that fnegd and negd had been inverted --- mppa_k1c/Asm.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 520bc453..23b11a03 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -181,7 +181,7 @@ Definition basic_to_instruction (b: basic) := (* RR *) | PArithRR Asmblock.Pmv rd rs => Pmv rd rs | PArithRR Asmblock.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmblock.Pnegl rd rs => Pfnegd rd rs + | PArithRR Asmblock.Pnegl rd rs => Pnegl rd rs | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs | PArithRR Asmblock.Pmvw2l rd rs => Pmvw2l rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs -- cgit From 51a27f176b0eb5fb2943807a5cb95f2024420936 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 11 Dec 2018 14:26:46 +0100 Subject: Fixed div64 and mod64 --- mppa_k1c/CBuiltins.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index a5bdaa28..147bbb55 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -59,6 +59,7 @@ 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, []), -- cgit From ac666e83b2d4d41fa193aef4f81233e3d5735506 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 11 Dec 2018 16:44:42 +0100 Subject: Added an error message for 32-bits division and modulo --- mppa_k1c/Asmblockgen.v | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 8bcbc712..2d345fe0 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -398,19 +398,19 @@ Definition transl_op | Omulhu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhuw rd rs1 rs2 :: k) - | Odiv, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivw rd rs1 rs2 :: k) - | Odivu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivuw rd rs1 rs2 :: k) - | Omod, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premw rd rs1 rs2 :: k) - | Omodu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premuw rd rs1 rs2 :: k) -*)| Oand, a1 :: a2 :: nil => +*)| Odiv, a1 :: a2 :: nil => Error(msg "32-bits division not supported yet. Please use 64-bits.") + (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivw rd rs1 rs2 :: k) *) + | Odivu, a1 :: a2 :: nil => Error(msg "32-bits division not supported yet. Please use 64-bits.") + (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivuw rd rs1 rs2 :: k) *) + | Omod, a1 :: a2 :: nil => Error(msg "32-bits modulo not supported yet. Please use 64-bits.") + (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premw rd rs1 rs2 :: k) *) + | Omodu, a1 :: a2 :: nil => Error(msg "32-bits modulo not supported yet. Please use 64-bits.") + (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premuw rd rs1 rs2 :: k) *) + | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 ::i k) | Oandimm n, a1 :: nil => -- cgit From ff1a4a32676fad3a78aad69d963f9f94bb07615c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Dec 2018 15:43:37 +0100 Subject: Added a simple postpass oracle that splits a bblock into single instruction bundles --- mppa_k1c/Asmexpand.ml | 2 ++ mppa_k1c/Asmgen.v | 4 +++- mppa_k1c/Asmgenproof.v | 10 +++++++--- mppa_k1c/PostpassScheduling.v | 2 ++ mppa_k1c/PostpassSchedulingOracle.ml | 18 ++++++++++++++++++ 5 files changed, 32 insertions(+), 4 deletions(-) create mode 100644 mppa_k1c/PostpassSchedulingOracle.ml (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 3209163f..47284e4b 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -448,6 +448,7 @@ let expand_instruction instr = let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); + emit Psemi; expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; let va_ofs = sz in @@ -456,6 +457,7 @@ let expand_instruction instr = save_arguments n va_ofs end else begin expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); + emit Psemi; expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; vararg_start_ofs := None end diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 6f61747f..58e80be1 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -17,6 +17,7 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. +Require Import PostpassScheduling. Require Import Errors. Local Open Scope error_monad_scope. @@ -24,7 +25,8 @@ Local Open Scope error_monad_scope. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := Machblockgen.transf_program p in do abp <- Asmblockgen.transf_program mbp; - OK (Asm.transf_program abp). + do abp' <- PostpassScheduling.transf_program abp; + OK (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 8eb0b693..588019a2 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -16,13 +16,14 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. -Require Import Machblockgenproof Asmblockgenproof. +Require Import Machblockgenproof Asmblockgenproof PostpassSchedulingproof. Local Open Scope linking_scope. Definition block_passes := mkpass Machblockgenproof.match_prog ::: mkpass Asmblockgenproof.match_prog + ::: mkpass PostpassSchedulingproof.match_prog ::: mkpass Asm.match_prog ::: pass_nil _. @@ -33,10 +34,12 @@ Lemma transf_program_match: Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. - inversion_clear H. inversion H1. remember (Machblockgen.transf_program p) as mbp. + inversion_clear H. apply bind_inversion in H1. destruct H1. + inversion_clear H. inversion H2. 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. + exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. exists tp; split. apply Asm.transf_program_match; auto. auto. Qed. @@ -147,12 +150,13 @@ Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. unfold match_prog in TRANSF. simpl in TRANSF. - inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. eapply compose_forward_simulations. exploit Machblockgenproof.transf_program_correct; eauto. unfold Machblockgenproof.inv_trans_rao. intros X; apply X. eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. apply Asm.transf_program_correct. eauto. Qed. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 5232f903..1483a5d7 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -19,6 +19,8 @@ Local Open Scope error_monad_scope. returns a schedule expressed as a list of bundles *) Axiom schedule: bblock -> list bblock. +Extract Constant schedule => "PostpassSchedulingOracle.schedule". + (* TODO - implement the verificator *) Definition verified_schedule (bb : bblock) : res (list bblock) := OK (schedule bb). diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml new file mode 100644 index 00000000..451a3b26 --- /dev/null +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -0,0 +1,18 @@ +open Asmblock + +let bundlize_label l = + match l with + | [] -> [] + | l -> [{ header = l; body = []; exit = None }] + +let rec bundlize_basic l = + match l with + | [] -> [] + | b :: l -> { header = []; body = [b]; exit = None } :: bundlize_basic l + +let bundlize_exit e = + match e with + | Some e -> [{ header = []; body = []; exit = Some e }] + | None -> [] + +let schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit -- cgit From 253d955435aa5f71a2772da65f810d7ad532d152 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 20 Dec 2018 17:50:36 +0100 Subject: [BROKEN] Début d'oracle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/InstructionScheduler.ml | 870 +++++++++++++++++++++++++++++++++++ mppa_k1c/InstructionScheduler.mli | 93 ++++ mppa_k1c/PostpassSchedulingOracle.ml | 106 ++++- 3 files changed, 1068 insertions(+), 1 deletion(-) create mode 100644 mppa_k1c/InstructionScheduler.ml create mode 100644 mppa_k1c/InstructionScheduler.mli (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml new file mode 100644 index 00000000..165ace4d --- /dev/null +++ b/mppa_k1c/InstructionScheduler.ml @@ -0,0 +1,870 @@ +(** Schedule instructions on a synchronized pipeline +@author David Monniaux, CNRS, VERIMAG *) + +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int };; + +type problem = { + max_latency : int; + resource_bounds : int array; + instruction_usages : int array array; + latency_constraints : latency_constraint list; + } + +let get_nr_instructions problem = Array.length problem.instruction_usages;; +let get_nr_resources problem = Array.length problem.resource_bounds;; + +type solution = int array +type scheduler = problem -> solution option + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option = + "caml_gecode_schedule_instr";; + *) + +let maximum_slot_used times = + let maxi = ref (-1) in + for i=0 to (Array.length times)-2 + do + maxi := max !maxi times.(i) + done; + !maxi;; + +let check_schedule (problem : problem) (times : solution) = + let nr_instructions = get_nr_instructions problem in + (if Array.length times <> nr_instructions+1 + then failwith + (Printf.sprintf "check_schedule: %d times expected, got %d" + (nr_instructions+1) (Array.length times))); + (if problem.max_latency >= 0 && times.(nr_instructions)> problem.max_latency + then failwith "check_schedule: max_latency exceeded"); + (Array.iteri (fun i time -> + (if time < 0 + then failwith (Printf.sprintf "time[%d] < 0" i))) times); + let slot_resources = Array.init ((maximum_slot_used times)+1) + (fun _ -> Array.copy problem.resource_bounds) in + for i=0 to nr_instructions -1 + do + let remaining_resources = slot_resources.(times.(i)) + and used_resources = problem.instruction_usages.(i) in + for resource=0 to (Array.length used_resources)-1 + do + let after = remaining_resources.(resource) - used_resources.(resource) in + (if after < 0 + then failwith (Printf.sprintf "check_schedule: instruction %d exceeds resource %d at slot %d" i resource times.(i))); + remaining_resources.(resource) <- after + done + done; + List.iter (fun ctr -> + if times.(ctr.instr_to) - times.(ctr.instr_from) < ctr.latency + then failwith (Printf.sprintf "check_schedule: time[%d]=%d - time[%d]=%d < %d" + ctr.instr_to times.(ctr.instr_to) + ctr.instr_from times.(ctr.instr_from) + ctr.latency) + ) problem.latency_constraints;; + +let bound_max_time problem = + let total = ref(Array.length problem.instruction_usages) in + List.iter (fun ctr -> total := !total + ctr.latency) problem.latency_constraints; + !total;; + +let vector_less_equal a b = + try + Array.iter2 (fun x y -> + if x>y + then raise Exit) a b; + true + with Exit -> false;; + +let vector_subtract a b = + assert ((Array.length a) = (Array.length b)); + for i=0 to (Array.length a)-1 + do + b.(i) <- b.(i) - a.(i) + done;; + +(* The version with critical path ordering is much better! *) +type list_scheduler_order = + | INSTRUCTION_ORDER + | CRITICAL_PATH_ORDER;; + +let int_max (x : int) (y : int) = + if x > y then x else y;; + +let int_min (x : int) (y : int) = + if x < y then x else y;; + +let get_predecessors problem = + let nr_instructions = get_nr_instructions problem in + let predecessors = Array.make (nr_instructions+1) [] in + List.iter (fun ctr -> + predecessors.(ctr.instr_to) <- + (ctr.instr_from, ctr.latency)::predecessors.(ctr.instr_to)) + problem.latency_constraints; + predecessors;; + +let get_successors problem = + let nr_instructions = get_nr_instructions problem in + let successors = Array.make nr_instructions [] in + List.iter (fun ctr -> + successors.(ctr.instr_from) <- + (ctr.instr_to, ctr.latency)::successors.(ctr.instr_from)) + problem.latency_constraints; + successors;; + +let critical_paths successors = + let nr_instructions = Array.length successors in + let path_lengths = Array.make nr_instructions (-1) in + let rec compute i = + if i=nr_instructions then 0 else + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 1 successors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = nr_instructions-1 downto 0 + do + ignore (compute i) + done; + path_lengths;; + +let maximum_critical_path problem = + let paths = critical_paths (get_successors problem) in + Array.fold_left int_max 0 paths;; + +let get_earliest_dates predecessors = + let nr_instructions = (Array.length predecessors)-1 in + let path_lengths = Array.make (nr_instructions+1) (-1) in + let rec compute i = + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 0 predecessors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = 0 to nr_instructions + do + ignore (compute i) + done; + for i = 0 to nr_instructions - 1 + do + path_lengths.(nr_instructions) <- int_max + path_lengths.(nr_instructions) (1 + path_lengths.(i)) + done; + path_lengths;; + +exception Unschedulable + +let get_latest_dates deadline successors = + let nr_instructions = Array.length successors + and path_lengths = critical_paths successors in + Array.init (nr_instructions + 1) + (fun i -> + if i < nr_instructions then + let path_length = path_lengths.(i) in + assert (path_length >= 1); + (if path_length > deadline + then raise Unschedulable); + deadline - path_length + else deadline);; + +let priority_list_scheduler (order : list_scheduler_order) + (problem : problem) : + solution option = + let nr_instructions = get_nr_instructions problem in + let successors = get_successors problem + and predecessors = get_predecessors problem + and times = Array.make (nr_instructions+1) (-1) in + + let priorities = match order with + | INSTRUCTION_ORDER -> None + | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in + + let module InstrSet = + Set.Make (struct type t=int + let compare = match priorities with + | None -> (fun x y -> x - y) + | Some p -> (fun x y -> + (match p.(y)-p.(x) with + | 0 -> x - y + | z -> z)) + end) in + + let max_time = bound_max_time problem in + let ready = Array.make max_time InstrSet.empty in + Array.iteri (fun i preds -> + if i + if times.(j) < 0 + then raise Exit + else let t = times.(j) + latency in + if t > !time + then time := t) predecessors.(i); + assert(!time >= 0); + !time + with Exit -> -1 + + in + let advance_time() = + begin + (if !current_time < max_time-1 + then + begin + Array.blit problem.resource_bounds 0 current_resources 0 + (Array.length current_resources); + ready.(!current_time + 1) <- + InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1)); + ready.(!current_time) <- InstrSet.empty; + end); + incr current_time + end in + + let attempt_scheduling ready usages = + let result = ref (-1) in + try + InstrSet.iter (fun i -> + (* Printf.printf "trying scheduling %d\n" i; + pr int_vector usages.(i); + print _vector current_resources; *) + if vector_less_equal usages.(i) current_resources + then + begin + vector_subtract usages.(i) current_resources; + result := i; + raise Exit + end) ready; + -1 + with Exit -> !result in + + while !current_time < max_time + do + if (InstrSet.is_empty ready.(!current_time)) + then advance_time() + else + match attempt_scheduling ready.(!current_time) + problem.instruction_usages with + | -1 -> advance_time() + | i -> + begin + assert(times.(i) < 0); + times.(i) <- !current_time; + ready.(!current_time) <- InstrSet.remove i (ready.(!current_time)); + List.iter (fun (instr_to, latency) -> + if instr_to < nr_instructions then + match earliest_time instr_to with + | -1 -> () + | to_time -> + ready.(to_time) <- InstrSet.add instr_to ready.(to_time)) + successors.(i); + successors.(i) <- [] + end + done; + try + let final_time = ref (-1) in + for i=0 to nr_instructions-1 + do + (if times.(i) < 0 then raise Exit); + (if !final_time < times.(i)+1 then final_time := times.(i)+1) + done; + List.iter (fun (i, latency) -> + let target_time = latency + times.(i) in + if target_time > !final_time + then final_time := target_time + ) predecessors.(nr_instructions); + times.(nr_instructions) <- !final_time; + Some times + with Exit -> None;; + +let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; + +(* alternate implementation +let swap_array_elements a i j = + let x = a.(i) in + a.(i) <- a.(j); + a.(j) <- x;; + +let array_reverse_slice a first last = + let i = ref first and j = ref last in + while i < j + do + swap_array_elements a !i !j; + incr i; + decr j + done;; + +let array_reverse a = + let a' = Array.copy a in + array_reverse_slice a' 0 ((Array.length a)-1); + a';; + *) + +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;; + +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) + problem.latency_constraints + };; + +let max_scheduled_time solution = + let time = ref (-1) in + for i = 0 to ((Array.length solution) - 2) + do + time := max !time solution.(i) + done; + !time;; + +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)));; + +(** Schedule the problem using a greedy list scheduling algorithm, from the end. *) +let reverse_list_scheduler = schedule_reversed list_scheduler;; + +let check_problem problem = + (if (Array.length problem.instruction_usages) < 1 + then failwith "length(problem.instruction_usages) < 1");; + +let validated_scheduler (scheduler : problem -> solution option) + (problem : problem) = + check_problem problem; + match scheduler problem with + | None -> None + | (Some solution) as ret -> check_schedule problem solution; ret;; + +let get_max_latency solution = + solution.((Array.length solution)-1);; + +let show_date_ranges problem = + let deadline = problem.max_latency in + assert(deadline >= 0); + let successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates : int array = get_earliest_dates predecessors + and latest_dates : int array = get_latest_dates deadline successors in + assert ((Array.length earliest_dates) = + (Array.length latest_dates)); + Array.iteri (fun i early -> + let late = latest_dates.(i) in + Printf.printf "t[%d] in %d..%d\n" i early late) + earliest_dates;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper = { + mapper_pb_type : pseudo_boolean_problem_type; + mapper_nr_instructions : int; + mapper_nr_pb_variables : int; + mapper_earliest_dates : int array; + mapper_latest_dates : int array; + mapper_var_offsets : int array; + mapper_final_predecessors : (int * int) list +};; + +(* Latency constraints are: + presence of instr-to at each t <= sum of presences of instr-from at compatible times + + if dual_encoding + presence of instr-from at each t <= sum of presences of instr-to at compatible times *) + +(* Experiments show dual_encoding=true multiplies time by 2 + without making hard instances easier *) +let dual_encoding = false + +let pseudo_boolean_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + let var_offsets = Array.make + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) 0 in + let nr_pb_variables = + (let nr = ref 0 in + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + var_offsets.(i) <- !nr; + nr := !nr + latest_dates.(i) - earliest_dates.(i) + 1 + done; + !nr) + and nr_pb_constraints = + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) + + + (let count = ref 0 in + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + try + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 then raise Exit + done + with Exit -> incr count + done + done; + !count) + + + (let count=ref 0 in + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions + then count := !count + 1 + latest_dates.(ctr.instr_to) + - earliest_dates.(ctr.instr_to) + + (if dual_encoding + then 1 + latest_dates.(ctr.instr_from) + - earliest_dates.(ctr.instr_from) + else 0) + ) + problem.latency_constraints; + !count) + + + (match pb_type with + | OPTIMIZATION -> (1 + deadline - earliest_dates.(nr_instructions)) * nr_instructions + | SATISFIABILITY -> 0) + and measured_nr_constraints = ref 0 in + + let pb_var i t = + assert(t >= earliest_dates.(i)); + assert(t <= latest_dates.(i)); + let v = 1+var_offsets.(i)+t-earliest_dates.(i) in + assert(v <= nr_pb_variables); + Printf.sprintf "x%d" v in + + let end_constraint () = + begin + output_string channel ";\n"; + incr measured_nr_constraints + end in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + Printf.fprintf channel ">= 0"; + end_constraint() + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0"; + end_constraint() + in + + Printf.fprintf channel "* #variable= %d #constraint= %d\n" nr_pb_variables nr_pb_constraints; + Printf.fprintf channel "* nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + output_string channel "min:"; + for t=earliest_dates.(nr_instructions) to deadline + do + Printf.fprintf channel " %+d %s" t (pb_var nr_instructions t) + done; + output_string channel ";\n"; + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "* t[%d] in %d..%d\n" i early late; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1"; + end_constraint() + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "* resource #%d at t=%d <= %d\n" j t bound; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d" (-bound); + end_constraint(); + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done; + if dual_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + assert (!measured_nr_constraints = nr_pb_constraints); + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = nr_pb_variables; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = var_offsets; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +type pb_answer = + | Positive + | Negative + | Unknown + +let line_to_pb_solution sol line nr_pb_variables = + let assign s v = + begin + let i = int_of_string s in + sol.(i-1) <- v + end in + List.iter + begin + function "" -> () + | item -> + (match String.get item 0 with + | '+' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Positive + | '-' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Negative + | 'x' -> + assert ((String.length item) >= 2); + assign (String.sub item 1 ((String.length item)-1)) Positive + ) + end + (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; + +let pb_solution_to_schedule mapper pb_solution = + Array.mapi (fun i offset -> + let first = mapper.mapper_earliest_dates.(i) + and last = mapper.mapper_latest_dates.(i) + and time = ref (-1) in + for t=first to last + do + match pb_solution.(t - first + offset) with + | Positive -> + (if !time = -1 + then time:=t + else failwith "duplicate time in pseudo boolean solution") + | Negative -> () + | Unknown -> failwith "unknown value in pseudo boolean solution" + done; + (if !time = -1 + then failwith "no time in pseudo boolean solution"); + !time + ) mapper.mapper_var_offsets;; + +let pseudo_boolean_read_solution mapper channel = + let optimum = ref (-1) + and optimum_found = ref false + and solution = Array.make mapper.mapper_nr_pb_variables Unknown in + try + while true do + match input_line channel with + | "" -> () + | line -> + begin + match String.get line 0 with + | 'c' -> () + | 'o' -> + assert ((String.length line) >= 2); + assert ((String.get line 1) = ' '); + optimum := int_of_string (String.sub line 2 ((String.length line)-2)) + | 's' -> (match line with + | "s OPTIMUM FOUND" -> optimum_found := true + | "s SATISFIABLE" -> () + | "s UNSATISFIABLE" -> close_in channel; + raise Unschedulable + | _ -> failwith line) + | 'v' -> line_to_pb_solution solution line mapper.mapper_nr_pb_variables + | x -> Printf.printf "unknown: %s\n" line + end + done; + assert false + with End_of_file -> + close_in channel; + begin + let sol = pb_solution_to_schedule mapper solution in + sol + end;; + +let recompute_max_latency mapper solution = + let maxi = ref (-1) in + for i=0 to (mapper.mapper_nr_instructions-1) + do + maxi := int_max !maxi (1+solution.(i)) + done; + List.iter (fun (i, latency) -> + maxi := int_max !maxi (solution.(i) + latency)) mapper.mapper_final_predecessors; + !maxi;; + +let adjust_check_solution mapper solution = + match mapper.mapper_pb_type with + | OPTIMIZATION -> + let max_latency = recompute_max_latency mapper solution in + assert (max_latency = solution.(mapper.mapper_nr_instructions)); + solution + | SATISFIABILITY -> + let max_latency = recompute_max_latency mapper solution in + Array.init (mapper.mapper_nr_instructions+1) + (fun i -> if i < mapper.mapper_nr_instructions + then solution.(i) + else max_latency);; + +(* let pseudo_boolean_solver = ref "/local/monniaux/progs/naps/naps" *) +(* let pseudo_boolean_solver = ref "/local/monniaux/packages/sat4j/org.sat4j.pb.jar CuttingPlanes" *) + +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar CuttingPlanes" *) +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar" *) +(* let pseudo_boolean_solver = ref "clasp" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) + +let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" + +let pseudo_boolean_scheduler pb_type problem = + try + let filename_in = "problem.opb" and filename_out = "problem.sol" in + let opb_problem = open_out filename_in in + let mapper = pseudo_boolean_print_problem opb_problem problem pb_type in + close_out opb_problem; + + let opb_solution = Unix.open_process_in (!pseudo_boolean_solver ^ " " ^ filename_in) in + let ret = adjust_check_solution mapper (pseudo_boolean_read_solution mapper opb_solution) in + close_in opb_solution; + Some ret + with + | Unschedulable -> None;; + +let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = + Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); + flush stdout; + match scheduler + { problem with max_latency = (get_max_latency previous_solution)-1 } + with + | None -> previous_solution + | Some solution -> reoptimizing_scheduler scheduler solution problem;; + +let cascaded_scheduler (problem : problem) = + match validated_scheduler list_scheduler problem with + | None -> None + | Some initial_solution -> + let solution = reoptimizing_scheduler (validated_scheduler (pseudo_boolean_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 "%d < %d\n" latency2 latency1 + else if latency2 = latency1 + then Printf.printf "%d unchanged\n" latency1 + else failwith "optimizing not optimizing" + end; + Some solution;; + + +(* old + match validated_scheduler list_scheduler problem with + | None -> None + | (Some solution1) as some1 -> + let latency1 = get_max_latency solution1 in + begin + match validated_scheduler pseudo_boolean_scheduler + { problem with max_latency = latency1-1 } with + | None -> + Printf.printf "%d unchanged\n" latency1; + some1 + | (Some solution2) as some2 -> + let latency2 = get_max_latency solution2 in + Printf.printf "%d < %d\n" latency2 latency1; + some2 + end;; + *) + +let smt_var i = Printf.sprintf "t%d" i + +let is_resource_used problem j = + try + Array.iter (fun usages -> + if usages.(j) > 0 + then raise Exit) problem.instruction_usages; + false + with Exit -> true;; + +let smt_use_quantifiers = false + +let smt_print_problem channel problem = + let nr_instructions = get_nr_instructions problem in + let gen_smt_resource_constraint time j = + output_string channel "(<= (+"; + Array.iteri + (fun i usages -> + let usage=usages.(j) in + if usage > 0 + then Printf.fprintf channel " (ite (= %s %s) %d 0)" + time (smt_var i) usage) + problem.instruction_usages; + Printf.fprintf channel ") %d)" problem.resource_bounds.(j) + in + output_string channel "(set-option :produce-models true)\n"; + for i=0 to nr_instructions + do + Printf.fprintf channel "(declare-const %s Int)\n" (smt_var i); + Printf.fprintf channel "(assert (>= %s 0))\n" (smt_var i) + done; + for i=0 to nr_instructions-1 + do + Printf.fprintf channel "(assert (< %s %s))\n" + (smt_var i) (smt_var nr_instructions) + done; + (if problem.max_latency > 0 + then Printf.fprintf channel "(assert (<= %s %d))\n" + (smt_var nr_instructions) problem.max_latency); + List.iter (fun ctr -> + Printf.fprintf channel "(assert (>= (- %s %s) %d))\n" + (smt_var ctr.instr_to) + (smt_var ctr.instr_from) + ctr.latency) problem.latency_constraints; + for j=0 to (Array.length problem.resource_bounds)-1 + do + if is_resource_used problem j + then + begin + if smt_use_quantifiers + then + begin + Printf.fprintf channel + "; resource #%d <= %d\n(assert (forall ((t Int)) " + j problem.resource_bounds.(j); + gen_smt_resource_constraint "t" j; + output_string channel "))\n" + end + else + begin + (if problem.max_latency < 0 + then failwith "quantifier explosion needs max latency"); + for t=0 to problem.max_latency + do + Printf.fprintf channel + "; resource #%d <= %d at t=%d\n(assert " + j problem.resource_bounds.(j) t; + gen_smt_resource_constraint (string_of_int t) j; + output_string channel ")\n" + done + end + end + done; + output_string channel "(check-sat)(get-model)\n";; + diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli new file mode 100644 index 00000000..507a4cac --- /dev/null +++ b/mppa_k1c/InstructionScheduler.mli @@ -0,0 +1,93 @@ +(** Schedule instructions on a synchronized pipeline +by David Monniaux, CNRS, VERIMAG *) + +(** A latency constraint: instruction number [instr_to] should be scheduled at least [latency] clock ticks before [instr_from]. + +It is possible to specify [latency]=0, meaning that [instr_to] can be scheduled at the same clock tick as [instr_from], but not before. + +[instr_to] can be the special value equal to the number of instructions, meaning that it refers to the final output latency. *) +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int; +} +(** A scheduling problem. + +In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. +*) +type problem = { + (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) + max_latency : int; + + (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) + resource_bounds : int array; + + (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) + instruction_usages: int array array; + latency_constraints : latency_constraint list + };; + +(** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) +type solution = int array + +(** A scheduling algorithm. +The return value [Some x] is a solution [x]. +[None] means that scheduling failed. *) +type scheduler = problem -> solution option;; + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option + = "caml_gecode_schedule_instr" + *) + +(** Get the number the last scheduling time used for an instruction in a solution. +@return The last clock tick used *) +val maximum_slot_used : solution -> int + +(** Validate that a solution is truly a solution of a scheduling problem. +@raise Failure if validation fails *) +val check_schedule : problem -> solution -> unit + +(** Schedule the problem using a greedy list scheduling algorithm, from the start. +The first (according to instruction ordering) instruction that is ready (according to the latency constraints) is scheduled at the current clock tick. +Once a clock tick is full go to the next. + +@return [Some solution] when a solution is found, [None] if not. *) +val list_scheduler : problem -> solution option + +(** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) +val schedule_reversed : scheduler -> problem -> int array option + +(** Schedule a problem from the end using a list scheduler. BUGGY *) +val reverse_list_scheduler : problem -> int array option + +(** Check that a problem is well-formed. +@raise Failure if validation fails *) +val check_problem : problem -> unit + +(** Apply a scheduler and validate the result against the input problem. +@return The solution found +@raise Failure if validation fails *) +val validated_scheduler : scheduler -> problem -> solution option;; + +(** Get max latency from solution +@return Max latency *) +val get_max_latency : solution -> int;; + +(** Apply line scheduler then advanced solver +@return A solution if found *) +val cascaded_scheduler : problem -> solution option;; + +val show_date_ranges : problem -> unit;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper +val pseudo_boolean_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; +val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> solution;; +val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; + +val smt_print_problem : out_channel -> problem -> unit;; diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 451a3b26..9941bf73 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,5 +1,105 @@ open Asmblock +(** Resource functions *) +let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] + +let rec find_index elt l = + match l with + | [] -> raise Not_found + | e::l -> if (e == elt) then 0 + else 1 + find_index elt l + +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 + +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 + in Array.of_list (List.map resmap resource_names) + +(** Mapping instruction -> instruction info *) + +type inst_info = { + reservation : int array; + write_regs : gpreg list; + read_regs : gpreg list; +} + +(* Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) +type imm_encoding = S10 | U27l10 | E27u27l10 + +let encode_imm : imm_encoding = raise Not_found (* TODO *) + +let arith_rrr_info i rd rs1 rs2 = match i with + | Paddl -> { reservation=alu_tiny; write_regs = [rd]; read_regs = [rs1; rs2] } + | _ -> raise Not_found + +let arith_rri32_info i rd rs imm32 = match i with + | Paddiw -> let restbl = match encode_imm imm with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in + { reservation = restbl; write_regs = [rd]; read_regs = [rs] } + | _ -> raise Not_found + +let arith_rri64_info i rd rs imm64 = match i with + | Paddil -> let restbl = match encode_imm imm with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in + { reservation = restbl; write_regs = [rd]; read_regs = [rs]} + | _ -> raise Not_found + +let arith_info i = + match i with + | PArithRRI32 i rd rs imm -> arith_rri32_info i rd rs imm32 + | PArithRRI64 i rd rs imm64 -> arith_rri64_info i rd rs imm64 + | PArithRRR i rd rs1 rs2 -> arith_rrr_info i r0 r1 r2 + | _ -> raise Not_found + +let basic_info i = + match i with + | PArith i -> arith_info i + | _ -> raise Not_found + +let exit_info i = raise Not_found + +(** Instruction usages building *) +let rec basic_usages body = match body with + | [] -> [] + | bi :: body -> (basic_info bi).reservation :: (basic_usages body) + +let exit_usage exit = match exit with + | None -> [] + | Some ex -> [(control_info ex).reservation] + +let instruction_usages bb = Array.of_list ((basic_usages bb.body) @ (exit_usage bb.exit)) + +(** Latency constraints building *) +let latency_constraints bb = (* TODO *) + +(** Dumb schedule if the above doesn't work *) + let bundlize_label l = match l with | [] -> [] @@ -15,4 +115,8 @@ let bundlize_exit e = | Some e -> [{ header = []; body = []; exit = Some e }] | None -> [] -let schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit +let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit + +(** Called schedule function from Coq *) + +let schedule bb = dumb_schedule bb (* TODO - raccorder le scheduler de David ici *) -- cgit From 3f21b462519363cd082a500004d3a7af0699d61d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Jan 2019 18:15:26 +0100 Subject: Finished the immediate recognition part, started latency constraints --- mppa_k1c/PostpassSchedulingOracle.ml | 97 +++++++++++++++++++++++++++++------- 1 file changed, 78 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9941bf73..3c7fcab6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,4 +1,6 @@ open Asmblock +open Printf +open Camlcoq (** Resource functions *) let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] @@ -54,49 +56,106 @@ type inst_info = { (* Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) type imm_encoding = S10 | U27l10 | E27u27l10 -let encode_imm : imm_encoding = raise Not_found (* TODO *) +let rec pow a = function + | 0 -> 1 + | 1 -> a + | n -> let b = pow a (n/2) in + b * b * (if n mod 2 = 0 then 1 else a) + +let signed_interval n = begin + assert (n > 0); + let min = - pow 2 (n-1) + and max = pow 2 (n-1) - 1 + in (min, max) +end + +let within i interv = match interv with (min, max) -> (i >= min && i <= max) + +let signed_length i = + let rec f i n = + let interv = signed_interval n + in if (within i interv) then n else f i (n+1) + in f i 0 + +let encode_imm imm = + let i = Z.to_int imm + in let length = signed_length i + in if length <= 10 then S10 + else if length <= 37 then U27l10 + else if length <= 64 then E27u27l10 + else failwith @@ sprintf "encode_imm: integer too big! (%d)" i + +(** Instruction usages building *) let arith_rrr_info i rd rs1 rs2 = match i with | Paddl -> { reservation=alu_tiny; write_regs = [rd]; read_regs = [rs1; rs2] } - | _ -> raise Not_found + | _ -> failwith "arith_rrr_info: unrecognized constructor" let arith_rri32_info i rd rs imm32 = match i with - | Paddiw -> let restbl = match encode_imm imm with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in + | Paddiw -> let restbl = match encode_imm imm32 with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in { reservation = restbl; write_regs = [rd]; read_regs = [rs] } - | _ -> raise Not_found + | _ -> failwith "arith_rri32_info: unrecognized constructor" let arith_rri64_info i rd rs imm64 = match i with - | Paddil -> let restbl = match encode_imm imm with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in + | Paddil -> let restbl = match encode_imm imm64 with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in { reservation = restbl; write_regs = [rd]; read_regs = [rs]} - | _ -> raise Not_found + | _ -> failwith "arith_rri64_info: unrecognized constructor" let arith_info i = match i with - | PArithRRI32 i rd rs imm -> arith_rri32_info i rd rs imm32 - | PArithRRI64 i rd rs imm64 -> arith_rri64_info i rd rs imm64 - | PArithRRR i rd rs1 rs2 -> arith_rrr_info i r0 r1 r2 - | _ -> raise Not_found + | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_info i rd rs imm32 + | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_info i rd rs imm64 + | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_info i rd rs1 rs2 + | _ -> failwith "arith_info: unrecognized constructor" let basic_info i = match i with | PArith i -> arith_info i - | _ -> raise Not_found + | _ -> failwith "basic_info: unrecognized constructor" -let exit_info i = raise Not_found +let control_info i = failwith "control_info: not implemented" -(** Instruction usages building *) -let rec basic_usages body = match body with +let rec basic_infos body = match body with | [] -> [] - | bi :: body -> (basic_info bi).reservation :: (basic_usages body) + | bi :: body -> (basic_info bi) :: (basic_infos body) -let exit_usage exit = match exit with +let exit_info exit = match exit with | None -> [] - | Some ex -> [(control_info ex).reservation] + | Some ex -> [control_info ex] + +let instruction_infos bb = (basic_infos bb.body) @ (exit_info bb.exit) -let instruction_usages bb = Array.of_list ((basic_usages bb.body) @ (exit_usage bb.exit)) +let instruction_usages bb = + let usages = List.map (fun info -> info.reservation) (instruction_infos bb) + in Array.of_list usages (** Latency constraints building *) -let latency_constraints bb = (* TODO *) +type access = { inst: int; reg: ireg } + +let rec get_accesses lregs laccs = + let accesses reg laccs = List.filter (fun acc -> acc.reg = reg) laccs + in match lregs with + | [] -> [] + | reg :: lregs -> (accesses reg laccs) @ (get_accesses lregs laccs) + +let latency_constraints bb = failwith "latency_constraints: not implemented" +(* TODO + let written = ref [] + and read = ref [] + and count = ref 0 + and constraints = ref [] + in let step i = + let write_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.write_regs + and read_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.read_regs + in let raw = get_accesses !written read_accesses + and waw = get_accesses !written write_accesses + and war = get_accesses !read write_accesses + in begin + (* TODO *) failwith "latency_constraints: not implemented" + end + and instr_infos = instruction_infos bb + in List.iter step instr_infos +*) (** Dumb schedule if the above doesn't work *) -- cgit From bc5f8909e299163b7daa7f363c84f1e3524ff270 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 8 Jan 2019 11:27:04 +0100 Subject: Fixed warnings in InstructionScheduler --- mppa_k1c/InstructionScheduler.ml | 38 ++++++++++++++++++++------------------ mppa_k1c/InstructionScheduler.mli | 7 ++++--- 2 files changed, 24 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 165ace4d..394c5264 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -88,7 +88,7 @@ let vector_subtract a b = (* The version with critical path ordering is much better! *) type list_scheduler_order = - | INSTRUCTION_ORDER + (* | INSTRUCTION_ORDER *) | CRITICAL_PATH_ORDER;; let int_max (x : int) (y : int) = @@ -134,9 +134,10 @@ let critical_paths successors = done; path_lengths;; -let maximum_critical_path problem = +(* let maximum_critical_path problem = let paths = critical_paths (get_successors problem) in Array.fold_left int_max 0 paths;; +*) let get_earliest_dates predecessors = let nr_instructions = (Array.length predecessors)-1 in @@ -185,7 +186,7 @@ let priority_list_scheduler (order : list_scheduler_order) and times = Array.make (nr_instructions+1) (-1) in let priorities = match order with - | INSTRUCTION_ORDER -> None + (* | INSTRUCTION_ORDER -> None *) | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in let module InstrSet = @@ -629,20 +630,21 @@ let line_to_pb_solution sol line nr_pb_variables = List.iter begin function "" -> () - | item -> - (match String.get item 0 with - | '+' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Positive - | '-' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Negative - | 'x' -> - assert ((String.length item) >= 2); - assign (String.sub item 1 ((String.length item)-1)) Positive - ) + | item -> + (match String.get item 0 with + | '+' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Positive + | '-' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Negative + | 'x' -> + assert ((String.length item) >= 2); + assign (String.sub item 1 ((String.length item)-1)) Positive + | c -> failwith @@ Printf.sprintf "line_to_pb_solution: unrecognized character: %c" c + ) end (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; @@ -737,7 +739,7 @@ let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" let pseudo_boolean_scheduler pb_type problem = try - let filename_in = "problem.opb" and filename_out = "problem.sol" in + let filename_in = "problem.opb" (* and filename_out = "problem.sol" *) in let opb_problem = open_out filename_in in let mapper = pseudo_boolean_print_problem opb_problem problem pb_type in close_out opb_problem; diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli index 507a4cac..aea5e909 100644 --- a/mppa_k1c/InstructionScheduler.mli +++ b/mppa_k1c/InstructionScheduler.mli @@ -11,18 +11,19 @@ type latency_constraint = { instr_to : int; latency : int; } + (** A scheduling problem. In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. *) type problem = { - (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) + (* An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) max_latency : int; - (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) + (* An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) resource_bounds : int array; - (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) + (* At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) instruction_usages: int array array; latency_constraints : latency_constraint list };; -- cgit From ea81391aa016d914d9fabfc209afddf230e65aa9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 8 Jan 2019 11:28:46 +0100 Subject: Reorganized PostpassOracle to separate asmblock instructions from real instructions --- mppa_k1c/PostpassSchedulingOracle.ml | 183 +++++++++++++++++++++-------------- 1 file changed, 111 insertions(+), 72 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3c7fcab6..eee8165b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,59 +1,71 @@ open Asmblock open Printf open Camlcoq +(* open InstructionScheduler *) -(** Resource functions *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] +(** + * Extracting infos from Asmblock instructions + *) -let rec find_index elt l = - match l with - | [] -> raise Not_found - | e::l -> if (e == elt) then 0 - else 1 + find_index elt l +type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int -let resource_id resource : int = find_index resource resource_names +type ab_inst_rec = { + inst: string; (* name of the pseudo instruction *) + write_regs : gpreg list; + read_regs : gpreg list; + imm : immediate option; +} -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 +let arith_rrr_rec i rd rs1 rs2 = match i with + | Paddl -> { inst="Paddl" ; write_regs = [rd]; read_regs = [rs1; rs2]; imm = None} + | _ -> failwith "arith_rrr_rec: unrecognized constructor" -let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) +let arith_rri32_rec i rd rs imm32 = match i with + | Paddiw -> + { inst = "Paddiw"; write_regs = [rd]; read_regs = [rs]; imm=imm32 } + | _ -> failwith "arith_rri32_rec: unrecognized constructor" -(** 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 arith_rri64_rec i rd rs imm64 = match i with + | Paddil -> + { inst = "Paddil"; write_regs = [rd]; read_regs = [rs]; imm=imm64 } + | _ -> failwith "arith_rri64_rec: unrecognized constructor" -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 arith_rec i = + match i with + | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i rd rs (Some (I32 imm32)) + | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i rd rs (Some (I64 imm64)) + | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i rd rs1 rs2 + | _ -> failwith "arith_rec: unrecognized constructor" -let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) +let basic_rec i = + match i with + | PArith i -> arith_rec i + | _ -> failwith "basic_rec: unrecognized constructor" + +let control_rec i = failwith "control_rec: not implemented" + +let rec basic_recs body = match body with + | [] -> [] + | bi :: body -> (basic_rec bi) :: (basic_recs body) + +let exit_rec exit = match exit with + | None -> [] + | Some ex -> [control_rec ex] -(** Mapping instruction -> instruction info *) +let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) +(** + * Providing informations relative to the real instructions + *) + +(** Abstraction providing all the necessary informations for solving the scheduling problem *) type inst_info = { - reservation : int array; write_regs : gpreg list; read_regs : gpreg list; + usage: int array; (* resources consumed by the instruction *) } -(* Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) +(** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) type imm_encoding = S10 | U27l10 | E27u27l10 let rec pow a = function @@ -85,48 +97,75 @@ let encode_imm imm = else if length <= 64 then E27u27l10 else failwith @@ sprintf "encode_imm: integer too big! (%d)" i -(** Instruction usages building *) +(** Resources *) +let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] -let arith_rrr_info i rd rs1 rs2 = match i with - | Paddl -> { reservation=alu_tiny; write_regs = [rd]; read_regs = [rs1; rs2] } - | _ -> failwith "arith_rrr_info: unrecognized constructor" +let rec find_index elt l = + match l with + | [] -> raise Not_found + | e::l -> if (e == elt) then 0 + else 1 + find_index elt l -let arith_rri32_info i rd rs imm32 = match i with - | Paddiw -> let restbl = match encode_imm imm32 with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in - { reservation = restbl; write_regs = [rd]; read_regs = [rs] } - | _ -> failwith "arith_rri32_info: unrecognized constructor" +let resource_id resource : int = find_index resource resource_names -let arith_rri64_info i rd rs imm64 = match i with - | Paddil -> let restbl = match encode_imm imm64 with S10 -> alu_tiny | U27l10 -> alu_tiny_x | E27u27l10 -> alu_tiny_y in - { reservation = restbl; write_regs = [rd]; read_regs = [rs]} - | _ -> failwith "arith_rri64_info: unrecognized constructor" +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 -let arith_info i = - match i with - | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_info i rd rs imm32 - | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_info i rd rs imm64 - | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_info i rd rs1 rs2 - | _ -> failwith "arith_info: unrecognized constructor" +let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) -let basic_info i = - match i with - | PArith i -> arith_info i - | _ -> failwith "basic_info: unrecognized constructor" +(** 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 control_info i = failwith "control_info: not implemented" +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 rec basic_infos body = match body with - | [] -> [] - | bi :: body -> (basic_info bi) :: (basic_infos body) +let alu_tiny_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) -let exit_info exit = match exit with - | None -> [] - | Some ex -> [control_info ex] +(** Real instructions *) + +type real_instruction = Addw | Addd + +let ab_inst_to_real = function + | "Paddl" | "Paddil" -> "addd" + | "Paddw" | "Paddiw" -> "addw" + | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s + +let rec_to_usage r = + let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm i) + and real_inst = ab_inst_to_real r.inst + and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" i + in match real_inst with + | "addw" -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> fail real_inst) + | "addd" -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> alu_tiny_y) + | s -> fail s + +let rec_to_info r : inst_info = + let usage = rec_to_usage r + in { write_regs = r.write_regs; read_regs = r.read_regs; usage=usage } -let instruction_infos bb = (basic_infos bb.body) @ (exit_info bb.exit) +let instruction_infos bb = List.map rec_to_info (instruction_recs bb) let instruction_usages bb = - let usages = List.map (fun info -> info.reservation) (instruction_infos bb) + let usages = List.map (fun info -> info.usage) (instruction_infos bb) in Array.of_list usages (** Latency constraints building *) @@ -138,8 +177,8 @@ let rec get_accesses lregs laccs = | [] -> [] | reg :: lregs -> (accesses reg laccs) @ (get_accesses lregs laccs) -let latency_constraints bb = failwith "latency_constraints: not implemented" -(* TODO +let latency_constraints bb = failwith "latency_constraints: not implemented" + (* let written = ref [] and read = ref [] and count = ref 0 @@ -155,7 +194,7 @@ let latency_constraints bb = failwith "latency_constraints: not implemented" end and instr_infos = instruction_infos bb in List.iter step instr_infos -*) + *) (** Dumb schedule if the above doesn't work *) -- cgit From 851efcb77032ba85878fdb7187be4107b2d96bc9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 8 Jan 2019 13:39:55 +0100 Subject: Latency constraints building done in PostpassSchedulingOracle.ml --- mppa_k1c/PostpassSchedulingOracle.ml | 44 +++++++++++++++++++++++------------- 1 file changed, 28 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index eee8165b..622fdbfb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,7 +1,7 @@ open Asmblock open Printf open Camlcoq -(* open InstructionScheduler *) +open InstructionScheduler (** * Extracting infos from Asmblock instructions @@ -63,6 +63,7 @@ type inst_info = { write_regs : gpreg list; read_regs : gpreg list; usage: int array; (* resources consumed by the instruction *) + latency: int; } (** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) @@ -144,23 +145,30 @@ let alu_tiny_y : int array = let resmap = fun r -> match r with type real_instruction = Addw | Addd +let real_inst_to_str = function + | Addw -> "addw" + | Addd -> "addd" + let ab_inst_to_real = function - | "Paddl" | "Paddil" -> "addd" - | "Paddw" | "Paddiw" -> "addw" + | "Paddl" | "Paddil" -> Addd + | "Paddw" | "Paddiw" -> Addw | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s let rec_to_usage r = let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm i) and real_inst = ab_inst_to_real r.inst - and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" i + and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" (real_inst_to_str i) in match real_inst with - | "addw" -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> fail real_inst) - | "addd" -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> alu_tiny_y) - | s -> fail s + | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> fail real_inst) + | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> alu_tiny_y) + +let real_inst_to_latency = function + | Addw | Addd -> 1 let rec_to_info r : inst_info = let usage = rec_to_usage r - in { write_regs = r.write_regs; read_regs = r.read_regs; usage=usage } + and latency = real_inst_to_latency @@ ab_inst_to_real r.inst + in { write_regs = r.write_regs; read_regs = r.read_regs; usage=usage; latency=latency } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) @@ -177,24 +185,28 @@ let rec get_accesses lregs laccs = | [] -> [] | reg :: lregs -> (accesses reg laccs) @ (get_accesses lregs laccs) -let latency_constraints bb = failwith "latency_constraints: not implemented" - (* +let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] and read = ref [] and count = ref 0 and constraints = ref [] - in let step i = + in let step (i: inst_info) = let write_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.write_regs and read_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.read_regs - in let raw = get_accesses !written read_accesses - and waw = get_accesses !written write_accesses - and war = get_accesses !read write_accesses + and written_regs = List.map (fun acc -> acc.reg) !written + and read_regs = List.map (fun acc -> acc.reg) !read + in let raw = get_accesses written_regs read_accesses + and waw = get_accesses written_regs write_accesses + and war = get_accesses read_regs write_accesses in begin - (* TODO *) failwith "latency_constraints: not implemented" + List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = i.latency} :: !constraints) (raw @ waw); + List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war; + written := write_accesses @ !written; + read := read_accesses @ !read; + count := !count + 1 end and instr_infos = instruction_infos bb in List.iter step instr_infos - *) (** Dumb schedule if the above doesn't work *) -- cgit From 3fe57ef6600242b41bb3f93ba0b4a093c263b6e9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 8 Jan 2019 17:04:50 +0100 Subject: Raccordement de InstructionScheduler.ml à PostpassSchedulingOracle.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingOracle.ml | 98 ++++++++++++++++++++++++++++++++++-- 1 file changed, 94 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 622fdbfb..1b728d1d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -176,7 +176,10 @@ let instruction_usages bb = let usages = List.map (fun info -> info.usage) (instruction_infos bb) in Array.of_list usages -(** Latency constraints building *) +(** + * Latency constraints building + *) + type access = { inst: int; reg: ireg } let rec get_accesses lregs laccs = @@ -206,9 +209,87 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" count := !count + 1 end and instr_infos = instruction_infos bb - in List.iter step instr_infos + in (List.iter step instr_infos; !constraints) + +(** + * Using the InstructionScheduler + *) + +let build_problem bb = + { max_latency = 5000; resource_bounds = resource_bounds; + instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } + +let rec find_min (l: int option list) = + match l with + | [] -> None + | e :: l -> + begin match find_min l with + | None -> e + | Some m -> + begin match e with + | None -> Some m + | Some n -> if n < m then Some n else Some m + end + end + +let rec filter_indexes predicate = function + | [] -> [] + | e :: l -> if (predicate e) then e :: (filter_indexes predicate l) else filter_indexes predicate l + +let get_from_indexes indexes l = List.map (List.nth l) indexes + +let is_basic = function PBasic _ -> true | _ -> false +let is_control = function PControl _ -> true | _ -> false +let to_basic = function PBasic i -> i | _ -> failwith "to_basic: control instruction found" +let to_control = function PControl i -> i | _ -> failwith "to_control: basic instruction found" + +let bundlize li hd = + let last = List.nth li (List.length li - 1) + in if is_control last then + let cut_li = Array.to_list @@ Array.sub (Array.of_list li) 0 (List.length li - 1) + in let bli = List.map to_basic cut_li + in { header = hd; body = bli; exit = Some (to_control last) } + else + let bli = List.map to_basic li + in { header = hd; body = bli; exit = None } + +let apply_pbasic b = PBasic b +let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found" + +let bundlize_solution bb sol = + let times = ref (Array.to_list @@ Array.map (fun t -> Some t) (Array.sub sol 0 (Array.length sol - 1))) + and is_first = ref true + and lbb = ref [] + and instrs = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) + in let next_instrs = + let next_time = find_min !times + in match next_time with + | None -> [] + | Some t -> + let next_indexes = filter_indexes (fun e -> match e with None -> false | Some tt -> t = tt) !times + in begin + times := List.map (fun e -> match e with None -> None | Some tt -> if (t = tt) then None else Some tt) !times; + get_from_indexes (List.map extract_some next_indexes) instrs + end + in let to_bundlize = ref [] + in begin + while (match next_instrs with [] -> false | li -> (to_bundlize := li; true)) do + let hd = if !is_first then (is_first := false; bb.header) else [] + in lbb := !lbb @ [bundlize !to_bundlize hd] + done; + !lbb + end + +let smart_schedule bb = + let problem = build_problem bb + in let solution = validated_scheduler list_scheduler problem + in match solution with + | None -> failwith "Could not find a valid schedule" + | Some sol -> bundlize_solution bb sol -(** Dumb schedule if the above doesn't work *) +(** + * Dumb schedule if the above doesn't work + *) let bundlize_label l = match l with @@ -229,4 +310,13 @@ let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundl (** Called schedule function from Coq *) -let schedule bb = dumb_schedule bb (* TODO - raccorder le scheduler de David ici *) +let schedule bb = + try smart_schedule bb + with e -> + let msg = Printexc.to_string e + and stack = Printexc.get_backtrace () + in begin + Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; + Printf.eprintf "Issuing one instruction per bundle instead\n\n"; + dumb_schedule bb + end -- cgit From f15dd4ff0f651546015a2e21c531da790a6398de Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 8 Jan 2019 18:00:28 +0100 Subject: Adding more Asmblock instructions to PostpassSchedulingOracle --- mppa_k1c/PostpassSchedulingOracle.ml | 122 +++++++++++++++++++++++++++++++---- 1 file changed, 108 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 1b728d1d..ac708479 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -2,12 +2,13 @@ open Asmblock open Printf open Camlcoq open InstructionScheduler +(* open TargetPrinter.Target *) (** * Extracting infos from Asmblock instructions *) -type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int +type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset type ab_inst_rec = { inst: string; (* name of the pseudo instruction *) @@ -16,19 +17,96 @@ type ab_inst_rec = { imm : immediate option; } -let arith_rrr_rec i rd rs1 rs2 = match i with - | Paddl -> { inst="Paddl" ; write_regs = [rd]; read_regs = [rs1; rs2]; imm = None} - | _ -> failwith "arith_rrr_rec: unrecognized constructor" - -let arith_rri32_rec i rd rs imm32 = match i with - | Paddiw -> - { inst = "Paddiw"; write_regs = [rd]; read_regs = [rs]; imm=imm32 } - | _ -> failwith "arith_rri32_rec: unrecognized constructor" - -let arith_rri64_rec i rd rs imm64 = match i with - | Paddil -> - { inst = "Paddil"; write_regs = [rd]; read_regs = [rs]; imm=imm64 } - | _ -> failwith "arith_rri64_rec: unrecognized constructor" +(** Asmblock constructor to string functions *) + +(* Because of a bug (from OCaml?), I cannot use TargetPrinter.Target.icond_name (unbound value error). Copy pasting instead *) +let icond_name = function + | ITne | ITneu -> "ne" + | ITeq | ITequ -> "eq" + | ITlt -> "lt" + | ITge -> "ge" + | ITle -> "le" + | ITgt -> "gt" + | ITltu -> "ltu" + | ITgeu -> "geu" + | ITleu -> "leu" + | ITgtu -> "gtu" + | ITall -> "all" + | ITnall -> "nall" + | ITany -> "any" + | ITnone -> "none" + +let bcond_name = function + | BTwnez -> "wnez" + | BTweqz -> "weqz" + | BTwltz -> "wltz" + | BTwgez -> "wgez" + | BTwlez -> "wlez" + | BTwgtz -> "wgtz" + | BTdnez -> "dnez" + | BTdeqz -> "deqz" + | BTdltz -> "dltz" + | BTdgez -> "dgez" + | BTdlez -> "dlez" + | BTdgtz -> "dgtz" + +let arith_rrr_str = function + | Pcompw it -> "Pcompw" ^ (icond_name it) + | Pcompl it -> "Pcompl" ^ (icond_name it) + | Paddw -> "Paddw" + | Psubw -> "Psubw" + | Pmulw -> "Pmulw" + | Pandw -> "Pandw" + | Porw -> "Porw" + | Pxorw -> "Pxorw" + | Psraw -> "Psraw" + | Psrlw -> "Psrlw" + | Psllw -> "Psllw" + | Paddl -> "Paddl" + | Psubl -> "Psubl" + | Pandl -> "Pandl" + | Porl -> "Porl" + | Pxorl -> "Pxorl" + | Pmull -> "Pmull" + | Pslll -> "Pslll" + | Psrll -> "Psrll" + | Psral -> "Psral" + +let arith_rri32_str = function + | Pcompiw it -> "Pcompiw" ^ (icond_name it) + | Paddiw -> "Paddiw" + | Pandiw -> "Pandiw" + | Poriw -> "Poriw" + | Pxoriw -> "Pxoriw" + | Psraiw -> "Psraiw" + | Psrliw -> "Psrliw" + | Pslliw -> "Pslliw" + | Psllil -> "Psllil" + | Psrlil -> "Psrlil" + | Psrail -> "Psrail" + +let arith_rri64_str = function + | Pcompil it -> "Pcompil" ^ (icond_name it) + | Paddil -> "Paddil" + | Pandil -> "Pandil" + | Poril -> "Poril" + | Pxoril -> "Pxoril" + +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 arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_regs = [rd]; read_regs = [rs1; rs2]; imm = None} + +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_regs = [rd]; read_regs = [rs]; imm = imm32 } + +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_regs = [rd]; read_regs = [rs]; imm = imm64 } let arith_rec i = match i with @@ -37,9 +115,24 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i rd rs1 rs2 | _ -> failwith "arith_rec: unrecognized constructor" +let load_rec i = failwith "load_rec: not implemented" + +let store_rec i = match i with + | PStoreRRO (i, rs1, rs2, imm) -> { inst = store_str i; write_regs = []; read_regs = [rs1; rs2]; imm = (Some (Off imm)) } + +let get_rec rd rs = failwith "get_rec: not implemented" + +let set_rec rd rs = failwith "set_rec: not implemented" + let basic_rec i = match i with | PArith i -> arith_rec i + | PLoad i -> load_rec i + | PStore i -> store_rec i + | Pallocframe (_, _) -> failwith "basic_rec: Pallocframe" + | Pfreeframe (_, _) -> failwith "basic_rec: Pfreeframe" + | Pget (rd, rs) -> get_rec rd rs + | Pset (rd, rs) -> set_rec rd rs | _ -> failwith "basic_rec: unrecognized constructor" let control_rec i = failwith "control_rec: not implemented" @@ -156,6 +249,7 @@ let ab_inst_to_real = function let rec_to_usage r = let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm i) + | Some (Off i) -> failwith "Offset encoding not supported yet" and real_inst = ab_inst_to_real r.inst and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" (real_inst_to_str i) in match real_inst with -- cgit From b75492e6a8135b35ef8846fbeed1e91678a2c7f0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 9 Jan 2019 17:29:56 +0100 Subject: [BROKEN] Added infos about sd, infinite loop somewhere --- mppa_k1c/PostpassSchedulingOracle.ml | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ac708479..ac53f5a4 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -181,10 +181,10 @@ let signed_length i = let rec f i n = let interv = signed_interval n in if (within i interv) then n else f i (n+1) - in f i 0 + in f i 1 let encode_imm imm = - let i = Z.to_int imm + let i = Int64.to_int imm in let length = signed_length i in if length <= 10 then S10 else if length <= 37 then U27l10 @@ -234,30 +234,48 @@ let alu_tiny_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 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 + 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 + 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 + in Array.of_list (List.map resmap resource_names) + (** Real instructions *) -type real_instruction = Addw | Addd +type real_instruction = Addw | Addd | Sd let real_inst_to_str = function | Addw -> "addw" | Addd -> "addd" + | Sd -> "sd" let ab_inst_to_real = function | "Paddl" | "Paddil" -> Addd | "Paddw" | "Paddiw" -> Addw + | "Psd" -> Sd | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s let rec_to_usage r = - let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm i) - | Some (Off i) -> failwith "Offset encoding not supported yet" + let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i) + | Some (Off (Ofsimm ptr)) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) + | Some (Off (Ofslow (_, _))) -> Some E27u27l10 (* FIXME *) + (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" (real_inst_to_str i) in match real_inst with | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> fail real_inst) | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> alu_tiny_y) + | Sd -> (match encoding with None | Some S10 -> lsu_acc | Some U27l10 -> lsu_acc_x | Some E27u27l10 -> lsu_acc_y) let real_inst_to_latency = function | Addw | Addd -> 1 + | Sd -> 5 (* FIXME - random value *) let rec_to_info r : inst_info = let usage = rec_to_usage r -- cgit From f8caf5f7564886dc43246c7477c4c22a7572e60d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Jan 2019 11:41:09 +0100 Subject: [BROKEN] trying to link the test in mppa_k1c/unittest/postpass_test --- mppa_k1c/PostpassSchedulingOracle.ml | 51 +++++++++++++----------------------- mppa_k1c/TargetPrinter.ml | 3 +-- mppa_k1c/unittest/Makefile | 12 +++++++++ mppa_k1c/unittest/postpass_test.ml | 12 +++++++++ 4 files changed, 43 insertions(+), 35 deletions(-) create mode 100644 mppa_k1c/unittest/Makefile create mode 100644 mppa_k1c/unittest/postpass_test.ml (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ac53f5a4..c647fc15 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -2,7 +2,9 @@ open Asmblock open Printf open Camlcoq open InstructionScheduler -(* open TargetPrinter.Target *) +open TargetPrinter.Target + +let debug = true (** * Extracting infos from Asmblock instructions @@ -19,37 +21,6 @@ type ab_inst_rec = { (** Asmblock constructor to string functions *) -(* Because of a bug (from OCaml?), I cannot use TargetPrinter.Target.icond_name (unbound value error). Copy pasting instead *) -let icond_name = function - | ITne | ITneu -> "ne" - | ITeq | ITequ -> "eq" - | ITlt -> "lt" - | ITge -> "ge" - | ITle -> "le" - | ITgt -> "gt" - | ITltu -> "ltu" - | ITgeu -> "geu" - | ITleu -> "leu" - | ITgtu -> "gtu" - | ITall -> "all" - | ITnall -> "nall" - | ITany -> "any" - | ITnone -> "none" - -let bcond_name = function - | BTwnez -> "wnez" - | BTweqz -> "weqz" - | BTwltz -> "wltz" - | BTwgez -> "wgez" - | BTwlez -> "wlez" - | BTwgtz -> "wgtz" - | BTdnez -> "dnez" - | BTdeqz -> "deqz" - | BTdltz -> "dltz" - | BTdgez -> "dgez" - | BTdlez -> "dlez" - | BTdgtz -> "dgtz" - let arith_rrr_str = function | Pcompw it -> "Pcompw" ^ (icond_name it) | Pcompl it -> "Pcompl" ^ (icond_name it) @@ -392,12 +363,24 @@ let bundlize_solution bb sol = !lbb end +let print_inst oc = function + | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" + | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" + | i -> print_instruction oc i + +let print_bb bb = + let asm_instructions = Asm.unfold_bblock bb + in List.iter (print_inst stdout) asm_instructions + +(* let[@warning "-26"] smart_schedule bb = print_bb bb; failwith "done" *) let smart_schedule bb = + ( printf "Attempting to schedule the basicblock:\n"; print_bb bb; printf "-----------------------------------\n"; let problem = build_problem bb in let solution = validated_scheduler list_scheduler problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> bundlize_solution bb sol + ) (** * Dumb schedule if the above doesn't work @@ -423,7 +406,8 @@ let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundl (** Called schedule function from Coq *) let schedule bb = - try smart_schedule bb + ( if debug then print_bb bb; + try smart_schedule bb with e -> let msg = Printexc.to_string e and stack = Printexc.get_backtrace () @@ -432,3 +416,4 @@ let schedule bb = Printf.eprintf "Issuing one instruction per bundle instead\n\n"; dumb_schedule bb end + ) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4f67ea65..cdede1ef 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -27,7 +27,7 @@ open Fileinfo (* Module containing the printing functions *) -module Target : TARGET = +module Target (*: TARGET*) = struct (* Basic printing functions *) @@ -412,7 +412,6 @@ module Target : TARGET = current_function_sig := fn.fn_sig; List.iter (print_instruction oc) fn.fn_code - (* Data *) let address = if Archi.ptr64 then ".quad" else ".long" diff --git a/mppa_k1c/unittest/Makefile b/mppa_k1c/unittest/Makefile new file mode 100644 index 00000000..fc7a51ac --- /dev/null +++ b/mppa_k1c/unittest/Makefile @@ -0,0 +1,12 @@ +# Needs to be called from CompCert root directory +# $ make -f mppa_k1c/unittest/Makefile postpass_test + +include Makefile.extr + +TEST_CMX=mppa_k1c/unittest/postpass_test.cmx + +UNITTEST_OBJS:=$(shell $(MODORDER) $(TEST_CMX)) + +postpass_test: $(TEST_CMX) $(UNITTEST_OBJS) + @echo "Linking $@" + @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ diff --git a/mppa_k1c/unittest/postpass_test.ml b/mppa_k1c/unittest/postpass_test.ml new file mode 100644 index 00000000..434bfaf7 --- /dev/null +++ b/mppa_k1c/unittest/postpass_test.ml @@ -0,0 +1,12 @@ +open Printf +open Asmblock +open Integers +open PostpassSchedulingOracle +open BinNums + +let test_schedule_sd = + let sd_inst = PStore (PStoreRRO (Psd, GPR12, GPR16, (Ofsimm (Ptrofs.of_int @@ Int.intval Z0)))) + in let bb = { header = []; body = [sd_inst]; exit = None } + in List.iter print_bb (smart_schedule bb) + +let _ = test_schedule_sd; printf "Done\n" -- cgit From 01828887dda772aca9e8bbddb3325cc939729ed4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 11 Jan 2019 16:52:07 +0100 Subject: quick and dirty Makefile fixes --- mppa_k1c/unittest/Makefile | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/unittest/Makefile b/mppa_k1c/unittest/Makefile index fc7a51ac..5e79efe4 100644 --- a/mppa_k1c/unittest/Makefile +++ b/mppa_k1c/unittest/Makefile @@ -7,6 +7,7 @@ TEST_CMX=mppa_k1c/unittest/postpass_test.cmx UNITTEST_OBJS:=$(shell $(MODORDER) $(TEST_CMX)) -postpass_test: $(TEST_CMX) $(UNITTEST_OBJS) - @echo "Linking $@" +postpass_test: $(UNITTEST_OBJS) + @echo "Linking $@ $(UNITTEST_OBJS)" @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ + -- cgit From 7f6bad146bdb7a10b8c4d3c3a28184fe59ef7bf5 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 11 Jan 2019 16:57:55 +0100 Subject: flush stdout --- mppa_k1c/PostpassSchedulingOracle.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c647fc15..40abf7eb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -375,6 +375,7 @@ let print_bb bb = (* let[@warning "-26"] smart_schedule bb = print_bb bb; failwith "done" *) let smart_schedule bb = ( printf "Attempting to schedule the basicblock:\n"; print_bb bb; printf "-----------------------------------\n"; + flush stdout; let problem = build_problem bb in let solution = validated_scheduler list_scheduler problem in match solution with -- cgit From 9efce61aa11c64041d6771a0d22887af9813399b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Jan 2019 17:17:41 +0100 Subject: Replaced the faulty bundlize_solution function --- mppa_k1c/PostpassSchedulingOracle.ml | 71 ++++++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 28 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c647fc15..d954b454 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -4,7 +4,7 @@ open Camlcoq open InstructionScheduler open TargetPrinter.Target -let debug = true +let debug = false (** * Extracting infos from Asmblock instructions @@ -302,11 +302,11 @@ let build_problem bb = { max_latency = 5000; resource_bounds = resource_bounds; instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } -let rec find_min (l: int option list) = +let rec find_min_opt (l: int option list) = match l with | [] -> None | e :: l -> - begin match find_min l with + begin match find_min_opt l with | None -> e | Some m -> begin match e with @@ -339,42 +339,54 @@ let bundlize li hd = let apply_pbasic b = PBasic b let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found" +let rec find_min = function + | [] -> None + | e :: l -> + match find_min l with + | None -> Some e + | Some m -> if (e < m) then Some e else Some m + +let rec remove_all m = function + | [] -> [] + | e :: l -> if m=e then remove_all m l + else e :: (remove_all m l) + +let rec find_mins l = match find_min l with + | None -> [] + | Some m -> m :: find_mins (remove_all m l) + +let find_all_indices m l = + let rec find m off = function + | [] -> [] + | e :: l -> if m=e then off :: find m (off+1) l + else find m (off+1) l + in find m 0 l + +(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) +let minpack_list l = + let mins = find_mins l + in List.map (fun m -> find_all_indices m l) mins + let bundlize_solution bb sol = - let times = ref (Array.to_list @@ Array.map (fun t -> Some t) (Array.sub sol 0 (Array.length sol - 1))) - and is_first = ref true - and lbb = ref [] + let packs = minpack_list (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) and instrs = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) - in let next_instrs = - let next_time = find_min !times - in match next_time with - | None -> [] - | Some t -> - let next_indexes = filter_indexes (fun e -> match e with None -> false | Some tt -> t = tt) !times - in begin - times := List.map (fun e -> match e with None -> None | Some tt -> if (t = tt) then None else Some tt) !times; - get_from_indexes (List.map extract_some next_indexes) instrs - end - in let to_bundlize = ref [] - in begin - while (match next_instrs with [] -> false | li -> (to_bundlize := li; true)) do - let hd = if !is_first then (is_first := false; bb.header) else [] - in lbb := !lbb @ [bundlize !to_bundlize hd] - done; - !lbb - end + in let rec bund hd = function + | [] -> [] + | pack :: packs -> bundlize (get_from_indexes pack instrs) hd :: (bund [] packs) + in bund bb.header packs let print_inst oc = function | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" | i -> print_instruction oc i -let print_bb bb = +let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb - in List.iter (print_inst stdout) asm_instructions + in List.iter (print_inst oc) asm_instructions (* let[@warning "-26"] smart_schedule bb = print_bb bb; failwith "done" *) let smart_schedule bb = - ( printf "Attempting to schedule the basicblock:\n"; print_bb bb; printf "-----------------------------------\n"; + ( let problem = build_problem bb in let solution = validated_scheduler list_scheduler problem in match solution with @@ -406,12 +418,15 @@ let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundl (** Called schedule function from Coq *) let schedule bb = - ( if debug then print_bb bb; + ( if debug then (print_bb stdout bb; printf "--------------------------\n"); + (* print_problem (build_problem bb); *) try smart_schedule bb with e -> let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in begin + Printf.eprintf "In regards to this group of instructions:"; + print_bb stderr bb; Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; Printf.eprintf "Issuing one instruction per bundle instead\n\n"; dumb_schedule bb -- cgit From a19cfffb026e8d0e26aeb366cdc9d76a04f459b6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Jan 2019 17:32:20 +0100 Subject: Adding Mem as a possible location for accesses --- mppa_k1c/PostpassSchedulingOracle.ml | 54 +++++++++++++++++++++--------------- 1 file changed, 31 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index d954b454..f01a3c91 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -12,10 +12,12 @@ let debug = false type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset +type location = Reg of gpreg | Mem + type ab_inst_rec = { inst: string; (* name of the pseudo instruction *) - write_regs : gpreg list; - read_regs : gpreg list; + write_locs : location list; + read_locs : location list; imm : immediate option; } @@ -73,11 +75,11 @@ let store_str = function | Pfss -> "Pfss" | Pfsd -> "Pfsd" -let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_regs = [rd]; read_regs = [rs1; rs2]; imm = None} +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} -let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_regs = [rd]; read_regs = [rs]; imm = imm32 } +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32 } -let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_regs = [rd]; read_regs = [rs]; imm = imm64 } +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64 } let arith_rec i = match i with @@ -89,7 +91,7 @@ let arith_rec i = let load_rec i = failwith "load_rec: not implemented" let store_rec i = match i with - | PStoreRRO (i, rs1, rs2, imm) -> { inst = store_str i; write_regs = []; read_regs = [rs1; rs2]; imm = (Some (Off imm)) } + | PStoreRRO (i, rs1, rs2, imm) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg rs1; Reg rs2]; imm = (Some (Off imm)) } let get_rec rd rs = failwith "get_rec: not implemented" @@ -106,7 +108,14 @@ let basic_rec i = | Pset (rd, rs) -> set_rec rd rs | _ -> failwith "basic_rec: unrecognized constructor" -let control_rec i = failwith "control_rec: not implemented" +let expand_rec i = failwith "expand_rec: not implemented" + +let ctl_flow_rec i = failwith "ctl_flow_rec: not implemented" + +let control_rec i = + match i with + | PExpand i -> expand_rec i + | PCtlFlow i -> ctl_flow_rec i let rec basic_recs body = match body with | [] -> [] @@ -124,8 +133,8 @@ let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) (** Abstraction providing all the necessary informations for solving the scheduling problem *) type inst_info = { - write_regs : gpreg list; - read_regs : gpreg list; + write_locs : location list; + read_locs : location list; usage: int array; (* resources consumed by the instruction *) latency: int; } @@ -251,7 +260,7 @@ let real_inst_to_latency = function 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_regs = r.write_regs; read_regs = r.read_regs; usage=usage; latency=latency } + in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) @@ -263,13 +272,13 @@ let instruction_usages bb = * Latency constraints building *) -type access = { inst: int; reg: ireg } +type access = { inst: int; loc: location } -let rec get_accesses lregs laccs = - let accesses reg laccs = List.filter (fun acc -> acc.reg = reg) laccs - in match lregs with +let rec get_accesses llocs laccs = + let accesses loc laccs = List.filter (fun acc -> acc.loc = loc) laccs + in match llocs with | [] -> [] - | reg :: lregs -> (accesses reg laccs) @ (get_accesses lregs laccs) + | loc :: llocs -> (accesses loc laccs) @ (get_accesses llocs laccs) let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] @@ -277,13 +286,13 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" and count = ref 0 and constraints = ref [] in let step (i: inst_info) = - let write_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.write_regs - and read_accesses = List.map (fun reg -> { inst= !count; reg=reg }) i.read_regs - and written_regs = List.map (fun acc -> acc.reg) !written - and read_regs = List.map (fun acc -> acc.reg) !read - in let raw = get_accesses written_regs read_accesses - and waw = get_accesses written_regs write_accesses - and war = get_accesses read_regs write_accesses + 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 + and written_locs = List.map (fun acc -> acc.loc) !written + and read_locs = List.map (fun acc -> acc.loc) !read + in let raw = get_accesses written_locs read_accesses + and waw = get_accesses written_locs write_accesses + and war = get_accesses read_locs write_accesses in begin List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = i.latency} :: !constraints) (raw @ waw); List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war; @@ -384,7 +393,6 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -(* let[@warning "-26"] smart_schedule bb = print_bb bb; failwith "done" *) let smart_schedule bb = ( let problem = build_problem bb -- cgit From f63ae70b28be93f2ab760e2a20b8c8621de2ffa2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Jan 2019 17:46:31 +0100 Subject: Added RA as possible location + control flow info --- mppa_k1c/PostpassSchedulingOracle.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f01a3c91..58c14757 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -12,7 +12,7 @@ let debug = false type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset -type location = Reg of gpreg | Mem +type location = Reg of preg | Mem type ab_inst_rec = { inst: string; (* name of the pseudo instruction *) @@ -83,15 +83,15 @@ let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Re let arith_rec i = match i with - | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i rd rs (Some (I32 imm32)) - | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i rd rs (Some (I64 imm64)) - | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i rd rs1 rs2 + | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) + | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) + | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) | _ -> failwith "arith_rec: unrecognized constructor" let load_rec i = failwith "load_rec: not implemented" let store_rec i = match i with - | PStoreRRO (i, rs1, rs2, imm) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg rs1; Reg rs2]; imm = (Some (Off imm)) } + | PStoreRRO (i, rs1, rs2, imm) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) } let get_rec rd rs = failwith "get_rec: not implemented" @@ -110,7 +110,13 @@ let basic_rec i = let expand_rec i = failwith "expand_rec: not implemented" -let ctl_flow_rec i = failwith "ctl_flow_rec: not implemented" +let ctl_flow_rec = function + | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None } + | Pcall lbl -> { inst = "Pcall"; write_locs = [Reg RA]; read_locs = []; imm = None } + | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; imm = None } + | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None } + | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None } + | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None } let control_rec i = match i with -- cgit From d95740f9ee990df3ab8d50a688c5b11bc2b4d02f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Jan 2019 11:21:32 +0100 Subject: Pfreeframe and Pallocframe raise "OpaqueInstruction". Splitting bb to isolate opaque instructions --- mppa_k1c/PostpassSchedulingOracle.ml | 73 +++++++++++++++++++++++++++--------- 1 file changed, 55 insertions(+), 18 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 58c14757..4185f931 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -23,6 +23,8 @@ type ab_inst_rec = { (** Asmblock constructor to string functions *) +exception OpaqueInstruction + let arith_rrr_str = function | Pcompw it -> "Pcompw" ^ (icond_name it) | Pcompl it -> "Pcompl" ^ (icond_name it) @@ -102,8 +104,8 @@ let basic_rec i = | PArith i -> arith_rec i | PLoad i -> load_rec i | PStore i -> store_rec i - | Pallocframe (_, _) -> failwith "basic_rec: Pallocframe" - | Pfreeframe (_, _) -> failwith "basic_rec: Pfreeframe" + | Pallocframe (_, _) -> raise OpaqueInstruction + | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs | _ -> failwith "basic_rec: unrecognized constructor" @@ -382,9 +384,11 @@ 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)) - and instrs = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) + and instrs = bb_to_instrs bb in let rec bund hd = function | [] -> [] | pack :: packs -> bundlize (get_from_indexes pack instrs) hd :: (bund [] packs) @@ -399,7 +403,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -let smart_schedule bb = +let do_schedule bb = ( let problem = build_problem bb in let solution = validated_scheduler list_scheduler problem @@ -429,20 +433,53 @@ let bundlize_exit e = let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit +(** + * Separates the opaque instructions such as Pfreeframe and Pallocframe + *) + +let is_opaque = function + | PBasic (Pallocframe (_, _)) | PBasic (Pfreeframe (_, _)) -> true + | _ -> false + +let rec biggest_wo_opaque = function + | [] -> ([], []) + | [i] -> ([i], []) + | i1 :: i2 :: li -> if is_opaque i2 || is_opaque i1 then ([i1], i2::li) + else let big, rem = biggest_wo_opaque li in (i1 :: i2 :: big, rem) + +let separate_opaque bb = + let instrs = bb_to_instrs bb + in let rec f hd = function + | [] -> [] + | li -> + let sub_li, li = biggest_wo_opaque li + in (bundlize sub_li hd) :: (f [] li) + in f bb.header instrs + +let smart_schedule bb = + let lbb = separate_opaque bb + in let rec f = function + | [] -> [] + | bb :: lbb -> + let bundles = + try do_schedule bb + with OpaqueInstruction -> dumb_schedule bb + | e -> + let msg = Printexc.to_string e + and stack = Printexc.get_backtrace () + in begin + Printf.eprintf "In regards to this group of instructions:\n"; + print_bb stderr bb; + Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; + Printf.eprintf "Issuing one instruction per bundle instead\n\n"; + dumb_schedule bb + end + in bundles @ (f lbb) + in f lbb + (** Called schedule function from Coq *) let schedule bb = - ( if debug then (print_bb stdout bb; printf "--------------------------\n"); - (* print_problem (build_problem bb); *) - try smart_schedule bb - with e -> - let msg = Printexc.to_string e - and stack = Printexc.get_backtrace () - in begin - Printf.eprintf "In regards to this group of instructions:"; - print_bb stderr bb; - Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; - Printf.eprintf "Issuing one instruction per bundle instead\n\n"; - dumb_schedule bb - end - ) + if debug then (print_bb stdout bb; printf "--------------------------\n"); + (* print_problem (build_problem bb); *) + smart_schedule bb -- cgit From 0d6f455f2ffca12ee758dd88656ad9c6a4a70ed5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Jan 2019 18:36:34 +0100 Subject: Debugged latency generation. We are able to produce bundles --- mppa_k1c/PostpassSchedulingOracle.ml | 101 +++++++++++++++++++++++++++-------- 1 file changed, 78 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 4185f931..ef12d190 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -4,7 +4,7 @@ open Camlcoq open InstructionScheduler open TargetPrinter.Target -let debug = false +let debug = true (** * Extracting infos from Asmblock instructions @@ -67,6 +67,10 @@ let arith_rri64_str = function | Poril -> "Poril" | Pxoril -> "Pxoril" +let arith_ri32_str = "Pmake" + +let arith_ri64_str = "Pmakel" + let store_str = function | Psb -> "Psb" | Psh -> "Psh" @@ -77,6 +81,21 @@ let store_str = function | 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_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None} let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32 } @@ -88,16 +107,19 @@ let arith_rec i = | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_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)) } + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) } | _ -> failwith "arith_rec: unrecognized constructor" -let load_rec i = failwith "load_rec: not implemented" +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)) } 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)) } -let get_rec rd rs = failwith "get_rec: not implemented" +let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None } -let set_rec rd rs = failwith "set_rec: not implemented" +let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None } let basic_rec i = match i with @@ -148,7 +170,7 @@ type inst_info = { } (** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) -type imm_encoding = S10 | U27l10 | E27u27l10 +type imm_encoding = S10 | U27L10 | E27U27L10 let rec pow a = function | 0 -> 1 @@ -175,8 +197,8 @@ let encode_imm imm = let i = Int64.to_int imm in let length = signed_length i in if length <= 10 then S10 - else if length <= 37 then U27l10 - else if length <= 64 then E27u27l10 + else if length <= 37 then U27L10 + else if length <= 64 then E27U27L10 else failwith @@ sprintf "encode_imm: integer too big! (%d)" i (** Resources *) @@ -222,6 +244,10 @@ let alu_tiny_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 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 + 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 in Array.of_list (List.map resmap resource_names) @@ -234,36 +260,60 @@ let lsu_acc_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 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 + 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 + 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 + in Array.of_list (List.map resmap resource_names) + (** Real instructions *) -type real_instruction = Addw | Addd | Sd +type real_instruction = Addw | Addd | Ld | Make | Sd | Set let real_inst_to_str = function | Addw -> "addw" | Addd -> "addd" + | Ld -> "ld" + | Make -> "make" | Sd -> "sd" + | Set -> "set" let ab_inst_to_real = function | "Paddl" | "Paddil" -> Addd | "Paddw" | "Paddiw" -> Addw + | "Pld" -> Ld + | "Pmake" | "Pmakel" -> Make | "Psd" -> Sd + | "Pset" -> Set | 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 (Ofsimm ptr)) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) - | Some (Off (Ofslow (_, _))) -> Some E27u27l10 (* FIXME *) + | Some (Off (Ofslow (_, _))) -> Some E27U27L10 (* FIXME *) (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" (real_inst_to_str i) in match real_inst with - | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> fail real_inst) - | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27l10 -> alu_tiny_x | Some E27u27l10 -> alu_tiny_y) - | Sd -> (match encoding with None | Some S10 -> lsu_acc | Some U27l10 -> lsu_acc_x | Some E27u27l10 -> lsu_acc_y) + | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> fail real_inst) + | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) + | Ld -> (match encoding with None | Some S10 -> lsu_data | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) + | Make -> (match encoding with Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) + | Sd -> (match encoding with None | Some S10 -> lsu_acc | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) + | Set -> bcu let real_inst_to_latency = function - | Addw | Addd -> 1 - | Sd -> 5 (* FIXME - random value *) + | Addw | Addd | Make -> 1 + | Ld | Sd -> 3 (* FIXME - random value *) + | Set -> 3 let rec_to_info r : inst_info = let usage = rec_to_usage r @@ -296,11 +346,9 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" 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 - and written_locs = List.map (fun acc -> acc.loc) !written - and read_locs = List.map (fun acc -> acc.loc) !read - in let raw = get_accesses written_locs read_accesses - and waw = get_accesses written_locs write_accesses - and war = get_accesses read_locs write_accesses + 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 begin List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = i.latency} :: !constraints) (raw @ waw); List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war; @@ -404,13 +452,20 @@ let print_bb oc bb = in List.iter (print_inst oc) asm_instructions let do_schedule bb = - ( let problem = build_problem bb in let solution = validated_scheduler list_scheduler problem in match solution with | None -> failwith "Could not find a valid schedule" - | Some sol -> bundlize_solution bb sol - ) + | Some sol -> let bundles = bundlize_solution bb sol in + (if debug then + begin + Printf.eprintf "Scheduling the following group of instructions:\n"; + print_bb stderr bb; + Printf.eprintf "Gave the following solution:\n"; + List.iter (print_bb stderr) bundles; + Printf.eprintf "--------------------------------\n" + end; + bundles) (** * Dumb schedule if the above doesn't work @@ -480,6 +535,6 @@ let smart_schedule bb = (** Called schedule function from Coq *) let schedule bb = - if debug then (print_bb stdout bb; printf "--------------------------\n"); + if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); (* print_problem (build_problem bb); *) smart_schedule bb -- cgit From 3c4639e92948b3db6c265300f532ed8ddaebc00c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 16 Jan 2019 14:24:17 +0100 Subject: More instruction definitions in the oracle --- mppa_k1c/PostpassSchedulingOracle.ml | 45 +++++++++++++++++++++++++++--------- mppa_k1c/TargetPrinter.ml | 3 ++- 2 files changed, 36 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ef12d190..60536ceb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -4,7 +4,7 @@ open Camlcoq open InstructionScheduler open TargetPrinter.Target -let debug = true +let debug = false (** * Extracting infos from Asmblock instructions @@ -25,6 +25,14 @@ type ab_inst_rec = { exception OpaqueInstruction +let arith_rr_str = function + | Pmv -> "Pmv" + | Pnegw -> "Pnegw" + | Pnegl -> "Pnegl" + | Pfnegd -> "Pfnegd" + | Pcvtl2w -> "Pcvtl2w" + | Pmvw2l -> "Pmvw2l" + let arith_rrr_str = function | Pcompw it -> "Pcompw" ^ (icond_name it) | Pcompl it -> "Pcompl" ^ (icond_name it) @@ -96,12 +104,21 @@ let load_str = function let set_str = "Pset" let get_str = "Pget" -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} - let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32 } let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64 } +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} + +let arith_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None} + +let arith_r_rec i rd = match i with + (* FIXME - this instruction is expanded to nothing, yet it still has a semantic in Asmblock.v. + * It will introduce unneeded dependencies.. *) + | Pcvtw2l -> { inst = "Pcvtw2l"; write_locs = [Reg rd]; read_locs = [Reg rd]; imm = None } + (* 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)} + let arith_rec i = match i with | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) @@ -109,7 +126,8 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_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)) } | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) } - | _ -> failwith "arith_rec: unrecognized constructor" + | 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)) } @@ -130,9 +148,10 @@ let basic_rec i = | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs - | _ -> failwith "basic_rec: unrecognized constructor" + | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None } -let expand_rec i = failwith "expand_rec: not implemented" +let expand_rec = function + | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None } @@ -274,13 +293,14 @@ let lsu_data_y : int array = let resmap = fun r -> match r with (** Real instructions *) -type real_instruction = Addw | Addd | Ld | Make | Sd | Set +type real_instruction = Addw | Addd | Ld | Make | Ret | Sd | Set let real_inst_to_str = function | Addw -> "addw" | Addd -> "addd" | Ld -> "ld" | Make -> "make" + | Ret -> "ret" | Sd -> "sd" | Set -> "set" @@ -289,6 +309,7 @@ let ab_inst_to_real = function | "Paddw" | "Paddiw" -> Addw | "Pld" -> Ld | "Pmake" | "Pmakel" -> Make + | "Pret" -> Ret | "Psd" -> Sd | "Pset" -> Set | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s @@ -305,15 +326,16 @@ let rec_to_usage r = in match real_inst with | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> fail real_inst) | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) - | Ld -> (match encoding with None | Some S10 -> lsu_data | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) | Make -> (match encoding with Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) + | Ld -> (match encoding with None | Some S10 -> lsu_data | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) | Sd -> (match encoding with None | Some S10 -> lsu_acc | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) - | Set -> bcu + | Ret | Set -> bcu let real_inst_to_latency = function | Addw | Addd | Make -> 1 | Ld | Sd -> 3 (* FIXME - random value *) - | Set -> 3 + | Set -> 3 (* FIXME *) + | Ret -> 5 (* Should not matter since it's the final instruction of the basic block *) let rec_to_info r : inst_info = let usage = rec_to_usage r @@ -445,6 +467,7 @@ let bundlize_solution bb sol = let print_inst oc = function | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" + | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" | i -> print_instruction oc i let print_bb oc bb = @@ -493,7 +516,7 @@ let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundl *) let is_opaque = function - | PBasic (Pallocframe (_, _)) | PBasic (Pfreeframe (_, _)) -> true + | PBasic (Pallocframe _) | PBasic (Pfreeframe _) | PControl (PExpand (Pbuiltin _)) -> true | _ -> false let rec biggest_wo_opaque = function diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index cdede1ef..7db82f6f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -268,7 +268,8 @@ module Target (*: TARGET*) = fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd (* Arith R instructions *) - | Pcvtw2l(rd) -> assert false + | Pcvtw2l(rd) -> assert false + (* Converted to no instruction in Asmexpand *) (* Arith RR instructions *) | Pmv(rd, rs) | Pmvw2l(rd, rs) -> -- cgit From 319f7614c03c3f4c50fcd513c91cc262cea6e117 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 16 Jan 2019 17:32:00 +0100 Subject: Added the rest of the instructions info (manually) --- mppa_k1c/PostpassSchedulingOracle.ml | 207 +++++++++++++++++++++++++++-------- 1 file changed, 160 insertions(+), 47 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 60536ceb..100e1b49 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -19,6 +19,7 @@ type ab_inst_rec = { write_locs : location list; read_locs : location list; imm : immediate option; + is_control : bool; } (** Asmblock constructor to string functions *) @@ -104,40 +105,42 @@ let load_str = function 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 } +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 } +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} +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_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None} +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_r_rec i rd = match i with (* FIXME - this instruction is expanded to nothing, yet it still has a semantic in Asmblock.v. * It will introduce unneeded dependencies.. *) - | Pcvtw2l -> { inst = "Pcvtw2l"; write_locs = [Reg rd]; read_locs = [Reg rd]; imm = None } + | Pcvtw2l -> { inst = "Pcvtw2l"; write_locs = [Reg rd]; read_locs = [Reg rd]; imm = None ; is_control = false} (* 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)} + | Ploadsymbol (id, ofs) -> { inst = "Ploadsymbol"; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false} let arith_rec i = match i with | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_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)) } - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) } + | 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} | 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)) } + | 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} 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)) } + | 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} -let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None } +let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } -let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None } +let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false } let basic_rec i = match i with @@ -148,18 +151,18 @@ 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 } + | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false} let expand_rec = function | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function - | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None } - | Pcall lbl -> { inst = "Pcall"; write_locs = [Reg RA]; read_locs = []; imm = None } - | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; imm = None } - | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None } - | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None } - | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None } + | 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} + | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; 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} let control_rec i = match i with @@ -184,12 +187,13 @@ let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) type inst_info = { write_locs : location list; read_locs : location list; + is_control : bool; usage: int array; (* resources consumed by the instruction *) latency: int; } (** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) -type imm_encoding = S10 | U27L10 | E27U27L10 +type imm_encoding = U6 | S10 | U27L5 | U27L10 | E27U27L10 let rec pow a = function | 0 -> 1 @@ -215,7 +219,9 @@ let signed_length i = let encode_imm imm = let i = Int64.to_int imm in let length = signed_length i - in if length <= 10 then S10 + in if length <= 6 then U6 + else if length <= 10 then S10 + else if length <= 32 then U27L5 else if length <= 37 then U27L10 else if length <= 64 then E27U27L10 else failwith @@ sprintf "encode_imm: integer too big! (%d)" i @@ -263,10 +269,34 @@ let alu_tiny_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 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 + 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 + 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 + 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 + 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 + 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 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 + 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 in Array.of_list (List.map resmap resource_names) @@ -293,25 +323,63 @@ let lsu_data_y : int array = let resmap = fun r -> match r with (** Real instructions *) -type real_instruction = Addw | Addd | Ld | Make | Ret | Sd | Set - -let real_inst_to_str = function - | Addw -> "addw" - | Addd -> "addd" - | Ld -> "ld" - | Make -> "make" - | Ret -> "ret" - | Sd -> "sd" - | Set -> "set" +type real_instruction = + (* ALU *) + | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord + | Make | Nop + (* LSU *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld + | Sb | Sh | Sw | Sd + (* BCU *) + | Call | Cb | Goto | Ret | Get | Set + (* FPU *) + | Fnegd let ab_inst_to_real = function - | "Paddl" | "Paddil" -> Addd | "Paddw" | "Paddiw" -> Addw - | "Pld" -> Ld - | "Pmake" | "Pmakel" -> Make + | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd + | "Pandw" | "Pandiw" -> Andw + | "Pandl" | "Pandil" -> Andd + | "Pcompw" | "Pcompiw" -> Compw + | "Pcompl" | "Pcompil" -> Compd + | "Pmulw" -> Mulw + | "Pmull" -> Muld + | "Porw" | "Poriw" -> Orw + | "Porl" | "Poril" -> Ord + | "Psubw" | "Pnegw" -> Sbfw + | "Psubl" | "Pnegl" -> Sbfd + | "Psraw" | "Psraiw" -> Sraw + | "Psral" | "Psrail" -> Srad + | "Psrlw" | "Psrliw" -> Srlw + | "Psrll" | "Psrlil" -> Srld + | "Psllw" | "Pslliw" -> Sllw + | "Pslll" | "Psllil" -> Slld + | "Pxorw" | "Pxoriw" -> Xorw + | "Pxord" | "Pxoril" -> Xord + | "Pmake" | "Pmakel" | "Ploadsymbol" -> Make + | "Pnop" | "Pcvtwl2w" -> Nop + + | "Plb" -> Lbs + | "Plbu" -> Lbz + | "Plh" -> Lhs + | "Plhu" -> Lhz + | "Plw" | "Plw_a" | "Pfls" -> Lws + | "Pld" | "Pfld" | "Pld_a" -> Ld + + | "Psb" -> Sb + | "Psh" -> Sh + | "Psw" | "Psw_a" | "Pfss" -> Sw + | "Psd" | "Psd_a" | "Pfsd" -> Sd + + | "Pcb" | "Pcbu" -> Cb + | "Pcall" -> Call + | "Pgoto" | "Pj_l" -> Goto + | "Pget" -> Get | "Pret" -> Ret - | "Psd" -> Sd | "Pset" -> Set + + | "Pfnegd" -> Fnegd | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s exception InvalidEncoding @@ -322,25 +390,63 @@ let rec_to_usage r = | Some (Off (Ofslow (_, _))) -> Some E27U27L10 (* FIXME *) (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst - and fail i = failwith @@ sprintf "rec_to_usage: failed with instruction %s" (real_inst_to_str i) in match real_inst with - | Addw -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> fail real_inst) - | Addd -> (match encoding with None | Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) - | Make -> (match encoding with Some S10 -> alu_tiny | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Ld -> (match encoding with None | Some S10 -> lsu_data | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) - | Sd -> (match encoding with None | Some S10 -> lsu_acc | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) - | Ret | Set -> bcu + | Addw | Andw | Orw | Sbfw | Xorw -> + (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | _ -> raise InvalidEncoding) + | Addd | Andd | Ord | Sbfd | Xord -> + (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y) + | Compw -> (match encoding with None -> alu_tiny + | Some U6 | Some S10 | Some U27L5 -> alu_tiny_x + | _ -> raise InvalidEncoding) + | Compd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y) + | Make -> (match encoding with Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y + | _ -> raise InvalidEncoding) + | Mulw -> (match encoding with None -> mau + | Some U6 | Some S10 | Some U27L5 -> mau_x + | _ -> raise InvalidEncoding) + | Muld -> (match encoding with None | Some U6 | Some S10 -> mau + | Some U27L5 | Some U27L10 -> mau_x + | Some E27U27L10 -> mau_y) + | Nop -> alu_nop + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> + (match encoding with None | Some U6 | Some S10 -> lsu_data + | Some U27L5 | Some U27L10 -> lsu_data_x + | Some E27U27L10 -> lsu_data_y) + | Sb | Sh | Sw | Sd -> + (match encoding with None | Some U6 | Some S10 -> lsu_acc + | Some U27L5 | Some U27L10 -> lsu_acc_x + | Some E27U27L10 -> lsu_acc_y) + | Call | Cb | Goto | Ret | Set -> bcu + | Get -> bcu_tiny_tiny_mau_xnop + | Fnegd -> alu_lite let real_inst_to_latency = function - | Addw | Addd | Make -> 1 - | Ld | Sd -> 3 (* FIXME - random value *) - | Set -> 3 (* FIXME *) - | Ret -> 5 (* Should not matter since it's the final instruction of the basic block *) + | Nop -> 0 (* Only goes through ID *) + | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make + -> 1 + | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld + | Sb | Sh | Sw | Sd + -> 3 (* FIXME - random value *) + | Get -> 1 + | Set -> 3 + | Call | Cb | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) + | Fnegd -> 1 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 } + in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) @@ -360,6 +466,11 @@ let rec get_accesses llocs laccs = | [] -> [] | loc :: llocs -> (accesses loc laccs) @ (get_accesses llocs laccs) +let rec intlist n = + if n < 0 then failwith "intlist: n < 0" + else if n = 0 then [] + else n :: (intlist (n-1)) + let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] and read = ref [] @@ -374,6 +485,8 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" in begin List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = i.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 *) + 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; count := !count + 1 -- cgit From 15c5ca037eabb9891f7880bc2d517982ba34e769 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Jan 2019 13:33:01 +0100 Subject: Corrected a bug in PostlassSchedulingOracle:intlist provoking cycles --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 100e1b49..06985c1d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -469,7 +469,7 @@ let rec get_accesses llocs laccs = let rec intlist n = if n < 0 then failwith "intlist: n < 0" else if n = 0 then [] - else n :: (intlist (n-1)) + else (n-1) :: (intlist (n-1)) let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] -- cgit From c3fc0620d07a96fd75adc5c60aeb90f89fdc620e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Jan 2019 15:03:35 +0100 Subject: Merge corrections --- mppa_k1c/PostpassSchedulingOracle.ml | 11 +-- mppa_k1c/TargetPrinter.ml | 138 +++++++++++++++++------------------ 2 files changed, 75 insertions(+), 74 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 06985c1d..5c50d50a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -35,8 +35,8 @@ let arith_rr_str = function | Pmvw2l -> "Pmvw2l" let arith_rrr_str = function - | Pcompw it -> "Pcompw" ^ (icond_name it) - | Pcompl it -> "Pcompl" ^ (icond_name it) + | Pcompw it -> "Pcompw" + | Pcompl it -> "Pcompl" | Paddw -> "Paddw" | Psubw -> "Psubw" | Pmulw -> "Pmulw" @@ -57,7 +57,7 @@ let arith_rrr_str = function | Psral -> "Psral" let arith_rri32_str = function - | Pcompiw it -> "Pcompiw" ^ (icond_name it) + | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" | Pandiw -> "Pandiw" | Poriw -> "Poriw" @@ -70,7 +70,7 @@ let arith_rri32_str = function | Psrail -> "Psrail" let arith_rri64_str = function - | Pcompil it -> "Pcompil" ^ (icond_name it) + | Pcompil it -> "Pcompil" | Paddil -> "Paddil" | Pandil -> "Pandil" | Poril -> "Poril" @@ -337,7 +337,7 @@ type real_instruction = | Fnegd let ab_inst_to_real = function - | "Paddw" | "Paddiw" -> Addw + | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd | "Pandw" | "Pandiw" -> Andw | "Pandl" | "Pandil" -> Andd @@ -581,6 +581,7 @@ let print_inst oc = function | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" + | Asm.Pcvtl2w(rd, rs) -> fprintf oc " Pcvtl2w %a = %a\n" ireg rd ireg rs | i -> print_instruction oc i let print_bb oc bb = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index cd36b502..098027f2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -127,9 +127,9 @@ module Target (*: TARGET*) = let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); - fprintf oc " make %a = %s\n;;\n" ireg r (extern_atom id) + fprintf oc " make %a = %s\n" ireg r (extern_atom id) end else begin - fprintf oc " make %a = %a\n;;\n" ireg r symbol_offset (id, ofs) + fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) end (* Emit .file / .loc debugging directives *) @@ -188,12 +188,12 @@ module Target (*: TARGET*) = let bcond oc c = fprintf oc "%s" (bcond_name c) (* Printing of instructions *) + exception ShouldBeExpanded + let print_instruction oc = function (* Pseudo-instructions expanded in Asmexpand *) - | Pallocframe(sz, ofs) -> - assert false - | Pfreeframe(sz, ofs) -> - assert false + | Pallocframe(sz, ofs) -> assert false + | Pfreeframe(sz, ofs) -> assert false (* Pseudo-instructions that remain *) | Plabel lbl -> @@ -221,51 +221,51 @@ module Target (*: TARGET*) = | _ -> assert false end - | Pnop -> fprintf oc " nop\n;;\n" - | Psemi -> fprintf oc "" + | Pnop -> fprintf oc " nop\n" + | Psemi -> fprintf oc ";;\n" - | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs - | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Control flow instructions *) | Pget (rd, rs) -> - fprintf oc " get %a = %a\n;;\n" ireg rd preg rs + fprintf oc " get %a = %a\n" ireg rd preg rs | Pset (rd, rs) -> - fprintf oc " set %a = %a\n;;\n" preg rd ireg rs + fprintf oc " set %a = %a\n" preg rd ireg rs | Pret -> - fprintf oc " ret \n;;\n" + fprintf oc " ret \n" | Pcall(s) -> - fprintf oc " call %a\n;;\n" symbol s + fprintf oc " call %a\n" symbol s | Pgoto(s) -> - fprintf oc " goto %a\n;;\n" symbol s + fprintf oc " goto %a\n" symbol s | Pj_l(s) -> - fprintf oc " goto %a\n;;\n" print_label s + fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + fprintf oc " cb.%a %a?%a\n" bcond bt ireg r print_label lbl (* Load/Store instructions *) | Plb(rd, ra, ofs) -> - fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plbu(rd, ra, ofs) -> - fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lbz %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plh(rd, ra, ofs) -> - fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lhs %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plhu(rd, ra, ofs) -> - fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lhz %a = %a[%a]\n" ireg rd offset ofs ireg ra | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + fprintf oc " ld %a = %a[%a]\n" ireg rd offset ofs ireg ra | Psb(rd, ra, ofs) -> - fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sb %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psh(rd, ra, ofs) -> - fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sh %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd (* Arith R instructions *) | Pcvtw2l(rd) -> assert false @@ -273,102 +273,102 @@ module Target (*: TARGET*) = (* Arith RR instructions *) | Pmv(rd, rs) | Pmvw2l(rd, rs) -> - fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs + fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs | Pcvtl2w(rd, rs) -> assert false | Pnegl(rd, rs) -> assert Archi.ptr64; - fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs + fprintf oc " negd %a = %a\n" ireg rd ireg rs | Pnegw(rd, rs) -> - fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs + fprintf oc " negw %a = %a\n" ireg rd ireg rs | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd + fprintf oc " fnegd %a = %a\n" ireg rs ireg rd (* Arith RI32 instructions *) | Pmake (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm + fprintf oc " make %a, %a\n" ireg rd coqint imm (* Arith RI64 instructions *) | Pmakel (rd, imm) -> - fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm + fprintf oc " make %a, %a\n" ireg rd coqint64 imm (* Arith RRR instructions *) | Pcompw (it, rd, rs1, rs2) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 | Pcompl (it, rd, rs1, rs2) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 | Paddw (rd, rs1, rs2) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pmulw (rd, rs1, rs2) -> - fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porw (rd, rs1, rs2) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psllw (rd, rs1, rs2) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> - fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmull (rd, rs1, rs2) -> - fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pslll (rd, rs1, rs2) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrll (rd, rs1, rs2) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psral (rd, rs1, rs2) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> - fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm | Paddiw (rd, rs, imm) -> - fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psraiw (rd, rs, imm) -> - fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psllil (rd, rs, imm) -> - fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> - fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrail (rd, rs, imm) -> - fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm (* Arith RRI64 instructions *) | Pcompil (it, rd, rs, imm) -> - fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + 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;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = -- cgit From 5609035afa76eac2fd284a8ad5c190e2347ee88b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Jan 2019 15:53:47 +0100 Subject: Corrected a bug in Pallocframe expansion with va_args --- mppa_k1c/Asmexpand.ml | 9 ++++++--- mppa_k1c/PostpassSchedulingOracle.ml | 1 + 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 47284e4b..0252ce85 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -334,12 +334,13 @@ let _nbregargs_ = 12 let _alignment_ = 8 let save_arguments first_reg base_ofs = let open Asmblock in - for i = first_reg to (_nbregargs_ - 1) do + for i = first_reg to (_nbregargs_ - 1) do begin expand_storeind_ptr int_param_regs.(i) GPR12 - (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))) - done + (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))); + emit Psemi + end done let vararg_start_ofs : Z.t option ref = ref None @@ -450,6 +451,7 @@ let expand_instruction instr = expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); emit Psemi; expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; + emit Psemi; let va_ofs = sz in (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) @@ -459,6 +461,7 @@ let expand_instruction instr = expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); emit Psemi; expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; + emit Psemi; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 5c50d50a..4291316a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -582,6 +582,7 @@ let print_inst oc = function | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" | Asm.Pcvtl2w(rd, rs) -> fprintf oc " Pcvtl2w %a = %a\n" ireg rd ireg rs + | Asm.Pcvtw2l rd -> fprintf oc " Pcvtw2l %a\n" ireg rd | i -> print_instruction oc i let print_bb oc bb = -- cgit From 3039952eeba967a60bcca13b231cee7021f72daf Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Jan 2019 16:37:41 +0100 Subject: Ommited a ;; in va_arg_start macro --- mppa_k1c/Asmexpand.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 0252ce85..265de410 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -350,6 +350,7 @@ match !vararg_start_ofs with invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> expand_addptrofs Asmblock.GPR32 Asmblock.GPR12 (Ptrofs.repr ofs); + emit Psemi; expand_storeind_ptr Asmblock.GPR32 r Ptrofs.zero (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to -- cgit From c953ce47894f58f3fc88c0f93e6bcac9ad0301ac Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Jan 2019 17:39:40 +0100 Subject: Minor bug fixes --- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 4291316a..19d4d962 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -356,9 +356,9 @@ let ab_inst_to_real = function | "Psllw" | "Pslliw" -> Sllw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw - | "Pxord" | "Pxoril" -> Xord + | "Pxorl" | "Pxoril" -> Xord | "Pmake" | "Pmakel" | "Ploadsymbol" -> Make - | "Pnop" | "Pcvtwl2w" -> Nop + | "Pnop" | "Pcvtw2l" -> Nop | "Plb" -> Lbs | "Plbu" -> Lbz -- cgit From 2fd1d6bc76a49116251b7d7fed2e4db93b9570d4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 18 Jan 2019 11:36:47 +0100 Subject: Minor bug in encode_imm --- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 19d4d962..a3851373 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -219,9 +219,9 @@ let signed_length i = let encode_imm imm = let i = Int64.to_int imm in let length = signed_length i - in if length <= 6 then U6 + in if length <= 7 then U6 (* Unsigned -> 1 bit less needed *) else if length <= 10 then S10 - else if length <= 32 then U27L5 + else if length <= 32 then U27L5 (* Upper 27 Lower 5 is signed *) else if length <= 37 then U27L10 else if length <= 64 then E27U27L10 else failwith @@ sprintf "encode_imm: integer too big! (%d)" i -- cgit From 458df74c1280ab4f6131272b20f8613cbd683f87 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 18 Jan 2019 15:22:03 +0100 Subject: -O0 will not perform postpass scheduling --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a3851373..083decde 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -675,4 +675,4 @@ let smart_schedule bb = let schedule bb = if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); (* print_problem (build_problem bb); *) - smart_schedule bb + if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb -- cgit From 5a5c643f127c44bfb86fe5c417db7bc561398499 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 18 Jan 2019 20:52:02 +0100 Subject: fix bug when using reoptimization (sat4j) --- mppa_k1c/InstructionScheduler.ml | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 394c5264..ae4296a2 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -735,7 +735,7 @@ let adjust_check_solution mapper solution = (* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) (* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) -let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" +let pseudo_boolean_solver = ref "java -jar /opt/sat4j/sat4j-pb.jar CuttingPlanesStar" let pseudo_boolean_scheduler pb_type problem = try @@ -752,14 +752,18 @@ let pseudo_boolean_scheduler pb_type problem = | Unschedulable -> None;; let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = - Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); - flush stdout; - match scheduler - { problem with max_latency = (get_max_latency previous_solution)-1 } - with - | None -> previous_solution - | Some solution -> reoptimizing_scheduler scheduler solution problem;; - + if (get_max_latency previous_solution) > 1 then + begin + Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); + flush stdout; + match scheduler + { problem with max_latency = (get_max_latency previous_solution)-1 } + with + | None -> previous_solution + | Some solution -> reoptimizing_scheduler scheduler solution problem + end + else previous_solution;; + let cascaded_scheduler (problem : problem) = match validated_scheduler list_scheduler problem with | None -> None -- cgit From 003ad4720496e04a849c18b402dff4c22dd1dee3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 Jan 2019 18:06:46 +0100 Subject: Un poil d'avancement sur PostpassSchedulingproof.v. Corrections à faire sur le modèle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 48 +++++++++++++++++++++++++++++++++++++- 1 file changed, 47 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 294ff0a1..f1eb26f1 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -75,13 +75,57 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. +Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : + forall a bb rs m lbb rs'' m'', + lbb <> nil -> + concat_all (a :: lbb) = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists bb' rs' m', + concat_all lbb = OK bb' + /\ exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. +Proof. + +Admitted. + +Lemma concat_all_size : + forall a lbb bb bb', + concat_all (a :: lbb) = OK bb -> + concat_all lbb = OK bb' -> + size bb = size a + size bb'. +Proof. +Admitted. + +Lemma ptrofs_add_repr : + forall a b, + Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). +Proof. + intros a b. + rewrite Ptrofs.add_unsigned. repeat (rewrite Ptrofs.unsigned_repr_eq). + rewrite <- Zplus_mod. auto. +Qed. + Theorem concat_exec_straight (ge: Genv.t fundef unit) (f: function) : forall lbb bb rs m rs' m' c, concat_all lbb = OK bb -> exec_bblock ge f bb rs m = Next rs' m' -> + rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) -> exec_straight_blocks ge f (lbb++c) rs m c rs' m'. Proof. -Admitted. + induction lbb; try discriminate. + intros until c. intros CONC EXEB. + destruct lbb as [| b lbb]. + - simpl in CONC. inv CONC. simpl. econstructor; eauto. + - exploit concat_exec_bblock_nonil; eauto; try discriminate. + intros (bb' & rs0 & m0 & CONC' & EXEB0 & PCeq & EXEB1). intros PCeq'. + eapply exec_straight_blocks_trans; eauto. + instantiate (3 := (b :: lbb) ++ c). + econstructor; eauto. + eapply IHlbb; eauto. + rewrite PCeq. rewrite Val.offset_ptr_assoc. + erewrite concat_all_size in PCeq'; eauto. +Admitted. (* FIXME - attention à l'hypothèse rs' PC qui n'est pas forcément vraie *) Section PRESERVATION. @@ -188,6 +232,8 @@ Proof. erewrite transf_exec_bblock in H2; eauto. exploit concat_exec_straight; eauto. { inv BBEQ. erewrite <- H3. eauto. } + { destruct TODO. } + (* FIXME - ce n'est pas forcément le cas en fait !! *) intros ESB. eexists. split. + eapply exec_straight_steps_1; eauto. -- cgit From 6acefcbbc51aa7d2edb7b2098a5b15d06e742604 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 22 Jan 2019 16:18:22 +0100 Subject: Added sxwd and zxwd support --- mppa_k1c/Asm.v | 10 ++++------ mppa_k1c/Asmblock.v | 8 ++++---- mppa_k1c/Asmblockgen.v | 13 ++++--------- mppa_k1c/Asmblockgenproof1.v | 10 +++++----- mppa_k1c/Asmexpand.ml | 4 ---- mppa_k1c/PostpassSchedulingOracle.ml | 13 ++++++++----- mppa_k1c/TargetPrinter.ml | 8 +++++--- 7 files changed, 30 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 23b11a03..eef5f39c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -87,16 +87,14 @@ Inductive instruction : Type := | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) - (** Arith R *) - | Pcvtw2l (rd: ireg) (**r Convert Word to Long *) - (** Arith RR *) | Pmv (rd rs: ireg) (**r register move *) | Pnegw (rd rs: ireg) (**r negate word *) | Pnegl (rd rs: ireg) (**r negate long *) | Pfnegd (rd rs: ireg) (**r float negate double *) | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Pmvw2l (rd rs: ireg) (**r Move Convert Word to Long *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) (** Arith RI32 *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) @@ -175,7 +173,6 @@ Definition basic_to_instruction (b: basic) := (** PArith basics *) (* R *) - | PArithR Asmblock.Pcvtw2l r => Pcvtw2l r | PArithR (Asmblock.Ploadsymbol id ofs) r => Ploadsymbol r id ofs (* RR *) @@ -183,7 +180,8 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pnegw rd rs => Pnegw rd rs | PArithRR Asmblock.Pnegl rd rs => Pnegl rd rs | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmblock.Pmvw2l rd rs => Pmvw2l rd rs + | PArithRR Asmblock.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs (* RI32 *) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index c11d043b..5d60af6b 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -269,7 +269,6 @@ Coercion PStoreRRO: store_name_rro >-> Funclass. (** Arithmetic instructions **) Inductive arith_name_r : Type := - | Pcvtw2l (**r Convert Word to Long *) | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) . @@ -279,7 +278,8 @@ Inductive arith_name_rr : Type := | Pnegl (**r negate long *) | Pfnegd (**r float negate double *) | Pcvtl2w (**r Convert Long to Word *) - | Pmvw2l (**r Move Convert Word to Long *) + | Psxwd (**r Sign Extend Word to Double Word *) + | Pzxwd (**r Zero Extend Word to Double Word *) . Inductive arith_name_ri32 : Type := @@ -797,7 +797,6 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset match ai with | PArithR n d => match n with - | Pcvtw2l => rs#d <- (Val.longofint rs#d) | Ploadsymbol s ofs => rs#d <- (Genv.symbol_address ge s ofs) end @@ -808,7 +807,8 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pnegl => rs#d <- (Val.negl rs#s) | Pfnegd => rs#d <- (Val.negf rs#s) | Pcvtl2w => rs#d <- (Val.loword rs#s) - | Pmvw2l => rs#d <- (Val.longofint rs#s) + | Psxwd => rs#d <- (Val.longofint rs#s) + | Pzxwd => rs#d <- (Val.longofintu rs#s) end | PArithRI32 n d i => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 9a564117..0d1dd49c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -115,12 +115,6 @@ Definition sltimm64 := opimm64 Psltl Psltil. Definition sltuimm64 := opimm64 Psltul Psltiul. *) -Definition cast32signed (rd rs: ireg) := - if (ireg_eq rd rs) - then Pcvtw2l rd - else Pmvw2l rd rs - . - Definition addptrofs (rd rs: ireg) (n: ptrofs) := if Ptrofs.eq_dec n Ptrofs.zero then Pmv rd rs @@ -460,11 +454,12 @@ Definition transl_op OK (Pcvtl2w rd rs ::i k) | Ocast32signed, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (cast32signed rd rs ::i k) + OK (Psxwd rd rs ::i k) | Ocast32unsigned, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - assertion (ireg_eq rd rs); - OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) + OK (Pzxwd rd rs ::i k) +(* assertion (ireg_eq rd rs); + OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) *) | Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 ::i k) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 2b653236..02301161 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1068,7 +1068,7 @@ Qed. (** Some arithmetic properties. *) -Remark cast32unsigned_from_cast32signed: +(* 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. @@ -1096,7 +1096,7 @@ Proof. + split. * Simpl. * intros. destruct r; Simpl. -Qed. +Qed. *) (* Translation of arithmetic operations *) @@ -1169,12 +1169,12 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. -- (* Ocast32signed *) +(* - (* Ocast32signed *) exploit cast32signed_correct; eauto. intros (rs' & A & B & C). exists rs'; split; eauto. split. apply B. intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } apply C; auto. -- (* longofintu *) + *)(* - (* longofintu *) econstructor; split. eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. split; intros; Simpl. (* unfold Pregmap.set; Simpl. *) destruct (PregEq.eq x0 x0). @@ -1182,7 +1182,7 @@ Opaque Int.eq. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. - + contradict n. auto. + + contradict n. auto. *) - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 265de410..de75df25 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -505,10 +505,6 @@ let expand_instruction instr = *)| Pcvtl2w (rd, rs) -> assert Archi.ptr64; emit (Paddiw (rd, rs, Int.zero)) (* 32-bit sign extension *) - | Pcvtw2l (r) -> (* Pcvtw2l *) - assert Archi.ptr64 - (* no-operation because the 32-bit integer was kept sign extended already *) - (* FIXME - is it really the case on the MPPA ? *) (*| Pjal_r(r, sg) -> fixup_call sg; emit instr diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 083decde..4d7c8636 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -27,12 +27,13 @@ type ab_inst_rec = { exception OpaqueInstruction let arith_rr_str = function + | Pcvtl2w -> "Pcvtl2w" | Pmv -> "Pmv" | Pnegw -> "Pnegw" | Pnegl -> "Pnegl" | Pfnegd -> "Pfnegd" - | Pcvtl2w -> "Pcvtl2w" - | Pmvw2l -> "Pmvw2l" + | Psxwd -> "Psxwd" + | Pzxwd -> "Pzxwd" let arith_rrr_str = function | Pcompw it -> "Pcompw" @@ -116,7 +117,6 @@ let arith_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_ let arith_r_rec i rd = match i with (* FIXME - this instruction is expanded to nothing, yet it still has a semantic in Asmblock.v. * It will introduce unneeded dependencies.. *) - | Pcvtw2l -> { inst = "Pcvtw2l"; write_locs = [Reg rd]; read_locs = [Reg rd]; imm = None ; is_control = false} (* 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} @@ -327,7 +327,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord - | Make | Nop + | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd @@ -359,6 +359,8 @@ let ab_inst_to_real = function | "Pxorl" | "Pxoril" -> Xord | "Pmake" | "Pmakel" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop + | "Psxwd" -> Sxwd + | "Pzxwd" -> Zxwd | "Plb" -> Lbs | "Plbu" -> Lbz @@ -417,6 +419,7 @@ let rec_to_usage r = | Some E27U27L10 -> mau_y) | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -433,6 +436,7 @@ let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make + | Sxwd | Zxwd -> 1 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -582,7 +586,6 @@ let print_inst oc = function | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" | Asm.Pcvtl2w(rd, rs) -> fprintf oc " Pcvtl2w %a = %a\n" ireg rd ireg rs - | Asm.Pcvtw2l rd -> fprintf oc " Pcvtw2l %a\n" ireg rd | i -> print_instruction oc i let print_bb oc bb = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 098027f2..36fab151 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -268,11 +268,9 @@ module Target (*: TARGET*) = fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd (* Arith R instructions *) - | Pcvtw2l(rd) -> assert false - (* Converted to no instruction in Asmexpand *) (* Arith RR instructions *) - | Pmv(rd, rs) | Pmvw2l(rd, rs) -> + | Pmv(rd, rs) -> fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs | Pcvtl2w(rd, rs) -> assert false | Pnegl(rd, rs) -> assert Archi.ptr64; @@ -281,6 +279,10 @@ module Target (*: TARGET*) = fprintf oc " negw %a = %a\n" ireg rd ireg rs | Pfnegd(rd, rs) -> fprintf oc " fnegd %a = %a\n" ireg rs ireg rd + | Psxwd(rd, rs) -> + fprintf oc " sxwd %a = %a\n" ireg rd ireg rs + | Pzxwd(rd, rs) -> + fprintf oc " zxwd %a = %a\n" ireg rd ireg rs (* Arith RI32 instructions *) | Pmake (rd, imm) -> -- cgit From f58bec109f818aacd04a27bb08fa9bbe64dccaf9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 22 Jan 2019 17:51:08 +0100 Subject: Léger avancement PostpassSchedulingproof.v MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f1eb26f1..5aedbf04 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -230,6 +230,12 @@ Proof. exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). erewrite transf_exec_bblock in H2; eauto. + inv BBEQ. rewrite H3 in H2. + eexists. split. + eapply plus_one. econstructor; eauto. + eapply find_bblock_tail. (* TODO - continue in this direction ? *) + all: destruct TODO. +(* OLD VERSION exploit concat_exec_straight; eauto. { inv BBEQ. erewrite <- H3. eauto. } { destruct TODO. } @@ -238,7 +244,7 @@ Proof. eexists. split. + eapply exec_straight_steps_1; eauto. monadInv EQ. destruct (zlt _ _). discriminate. monadInv EQ1. omega. - + econstructor; eauto. + + econstructor; eauto. *) - destruct TODO. - destruct TODO. Admitted. -- cgit From 5e543e5b28960058884cb9e01e41750375b79b7b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 23 Jan 2019 11:59:55 +0100 Subject: Changement de modèle de preuve pour le 1er cas du tranf_step_correct de PostpassSchedulingproof MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 61 +++++++++++++++++++++++++++++--------- 1 file changed, 47 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 5aedbf04..73a44058 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -134,6 +134,14 @@ Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +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. + Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. @@ -220,6 +228,41 @@ Admitted. Axiom TODO: False. +Lemma concat_all_equiv_cons: + forall tge tf bb lbb tbb rs m rs'' m'', + concat_all (bb::lbb) = OK tbb -> + exec_bblock tge tf tbb rs m = Next rs'' m'' -> + exists tbb' rs' m', + exec_bblock tge tf bb rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) + /\ concat_all lbb = OK tbb' + /\ exec_bblock tge tf tbb' rs' m' = Next rs'' m''. +Proof. +Admitted. + +Lemma transf_step_simu: + forall tf b lbb ofs c tbb rs m rs' m', + Genv.find_funct_ptr tge b = Some (Internal tf) -> + size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned -> + rs PC = Vptr b ofs -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c) -> + concat_all lbb = OK tbb -> + exec_bblock tge tf tbb rs m = Next rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + induction lbb. + - intros until m'. simpl. intros. discriminate. + - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. + exploit concat_all_equiv_cons; eauto. + intros (tbb0 & rs0 & m0 & EXEB0 & PCeq' & CONC0 & EXEB1). + eapply plus_left. + econstructor. + 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. + all: eauto. + eapply plus_star. eapply IHlbb; eauto. rewrite PCeq in PCeq'. simpl in PCeq'. all: eauto. + eapply code_tail_next_int; eauto. +Qed. + Theorem transf_step_correct: forall s1 t s2, step ge s1 t s2 -> forall s1' (MS: match_states s1 s1'), @@ -229,22 +272,12 @@ Proof. - 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). + assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. erewrite transf_exec_bblock in H2; eauto. inv BBEQ. rewrite H3 in H2. - eexists. split. - eapply plus_one. econstructor; eauto. - eapply find_bblock_tail. (* TODO - continue in this direction ? *) - all: destruct TODO. -(* OLD VERSION - exploit concat_exec_straight; eauto. - { inv BBEQ. erewrite <- H3. eauto. } - { destruct TODO. } - (* FIXME - ce n'est pas forcément le cas en fait !! *) - intros ESB. - eexists. split. - + eapply exec_straight_steps_1; eauto. - monadInv EQ. destruct (zlt _ _). discriminate. monadInv EQ1. omega. - + econstructor; eauto. *) + exists (State rs' m'). split; try (constructor; auto). + eapply transf_step_simu; eauto. - destruct TODO. - destruct TODO. Admitted. -- cgit From afe2e1ebb808fb2e281a09b76f29c64467fbb1e1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 23 Jan 2019 16:04:00 +0100 Subject: Adding a predicate that a builtin must be alone in its basicblock --- mppa_k1c/Asmblock.v | 218 +++++++++++++++++++++++-------------- mppa_k1c/Asmblockgen.v | 8 +- mppa_k1c/PostpassSchedulingproof.v | 30 +++-- 3 files changed, 168 insertions(+), 88 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 5d60af6b..14ceb082 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -30,6 +30,7 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. +Require Import Errors. (** * Abstract syntax *) @@ -384,6 +385,17 @@ Coercion PCtlFlow: cf_instruction >-> control. (** * Definition of a bblock *) +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. + Definition non_empty_bblock (body: list basic) (exit: option control): Prop := body <> nil \/ exit <> None. @@ -415,12 +427,54 @@ Proof. contradiction. Qed. -(* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, +Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. - *) -(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := - non_empty_bblock body exit (* /\ builtin_alone body exit *). *) +Definition builtin_aloneb (body: list basic) (exit: option control) := + match exit with + | Some (PExpand (Pbuiltin _ _ _)) => + match body with + | nil => true + | _ => false + end + | _ => true + end. + +Lemma builtin_alone_refl: + forall body exit, + builtin_alone body exit <-> Is_true (builtin_aloneb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. + all: exploreInst; simpl; auto. + unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. + assert (b :: body = nil). eapply H; eauto. discriminate. + - destruct body; destruct exit. + all: simpl; auto; try constructor. + + exploreInst. + simpl. contradiction. + discriminate. + + intros. discriminate. +Qed. + +Definition wf_bblockb (body: list basic) (exit: option control) := + (non_empty_bblockb body exit) && (builtin_aloneb body exit). + +Definition wf_bblock (body: list basic) (exit: option control) := + non_empty_bblock body exit /\ builtin_alone body exit. + +Lemma wf_bblock_refl: + forall body exit, + wf_bblock body exit <-> Is_true (wf_bblockb body exit). +Proof. + intros. split. + - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + apply andb_prop_intro. auto. + - intros. apply andb_prop_elim in H. inv H. + apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + unfold wf_bblock. split; auto. +Qed. (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -429,7 +483,7 @@ Record bblock := mk_bblock { header: list label; body: list basic; exit: option control; - correct: Is_true (non_empty_bblockb body exit) + correct: Is_true (wf_bblockb body exit) }. Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). @@ -582,8 +636,14 @@ Program Definition bblock_single_inst (i: instruction) := | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} end. +Next Obligation. + apply wf_bblock_refl. constructor. + right. discriminate. + constructor. +Qed. -Program Definition bblock_basic_ctl (c: list basic) (i: option control) := +(** This definition is not used anymore *) +(* Program Definition bblock_basic_ctl (c: list basic) (i: option control) := match i with | Some i => {| header:=nil; body:=c; exit:=Some i |} | None => @@ -596,7 +656,7 @@ Next Obligation. bblock_auto_correct. Qed. Next Obligation. bblock_auto_correct. -Qed. +Qed. *) (** * Operational semantics *) @@ -1310,75 +1370,75 @@ Ltac Equalities := inv H; inv H0. congruence. Qed. -Definition data_preg (r: preg) : bool := - match r with - | RA => false - | IR GPRA => false - | IR RTMP => false - | IR _ => true - | FR _ => true - | PC => false - end. - -(** Determinacy of the [Asm] semantics. *) - -(* TODO. - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. - split. constructor. auto. - discriminate. - discriminate. - assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H11. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. -*) +Definition data_preg (r: preg) : bool := + match r with + | RA => false + | IR GPRA => false + | IR RTMP => false + | IR _ => true + | FR _ => true + | PC => false + end. + +(** Determinacy of the [Asm] semantics. *) + +(* TODO. + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + split. constructor. auto. + discriminate. + discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H5. eexact H11. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. +*) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 0d1dd49c..e32748f8 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -891,9 +891,13 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr end . Next Obligation. - bblock_auto_correct. intros. constructor. apply not_eq_sym. auto. + apply wf_bblock_refl. constructor. + left. auto. + discriminate. Qed. Next Obligation. - bblock_auto_correct. + apply wf_bblock_refl. constructor. + right. discriminate. + discriminate. Qed. Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 73a44058..2b09bb01 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -41,22 +41,38 @@ Proof. - discriminate. Qed. +Lemma app_nonil2 {A: Type} : forall (l': list A) l, l' <> nil -> l ++ l' <> nil. +Proof. + induction l'; try contradiction. + intros. cutrewrite (l ++ a :: l' = (l ++ a :: nil) ++ l'). apply app_nonil. +Admitted. + Program Definition concat2 (bb bb': bblock) : res bblock := match (exit bb) with | None => match (header bb') with - | nil => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + | nil => + match (exit bb') with + | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") + | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + end | _ => Error (msg "PostpassSchedulingproof.concat2") end | _ => Error (msg "PostpassSchedulingproof.concat2") end. Next Obligation. - apply non_empty_bblock_refl. - destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']. simpl in *. - apply non_empty_bblock_refl in COR. apply non_empty_bblock_refl in COR'. - inv COR. - - left. apply app_nonil. auto. - - contradiction. + apply wf_bblock_refl. constructor. + - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. + inversion_clear WF'. inversion_clear WF. clear H1 H3. + inversion H2; inversion H0. + + left. apply app_nonil. auto. + + right. auto. + + left. apply app_nonil2. auto. + + right. auto. + - unfold builtin_alone. intros. rewrite H0 in H. + assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). + apply (H ef args res). contradict H1. auto. Qed. Fixpoint concat_all (lbb: list bblock) : res bblock := -- cgit From 463bcb7f90d7b0d803710b81b5bb47593d0cec65 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 23 Jan 2019 17:14:10 +0100 Subject: Proof of builtin case for transf_step_correct in PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingproof.v | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2b09bb01..fbb05ca2 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -256,6 +256,14 @@ Lemma concat_all_equiv_cons: Proof. Admitted. +Lemma verified_schedule_builtin_idem: + forall bi ef args res lbb, + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bi = OK lbb -> + lbb = bi :: nil. +Proof. +Admitted. + Lemma transf_step_simu: forall tf b lbb ofs c tbb rs m rs' m', Genv.find_funct_ptr tge b = Some (Internal tf) -> @@ -290,14 +298,30 @@ Proof. exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. + erewrite transf_exec_bblock in H2; eauto. inv BBEQ. rewrite H3 in H2. exists (State rs' m'). split; try (constructor; auto). eapply transf_step_simu; eauto. - - destruct TODO. + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). + exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. + exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). + assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + + remember (State (nextblock _ _) _) as s'. exists s'. + split; try constructor; auto. + eapply plus_one. subst s'. + eapply exec_step_builtin. + 3: eapply find_bblock_tail. simpl in TAIL. 3: eauto. + all: eauto. + eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. - destruct TODO. Admitted. + Theorem transf_program_correct: forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). Proof. -- cgit From 644aaedd3a62e9dcbfb6d0159564904b2be53285 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 23 Jan 2019 17:22:53 +0100 Subject: 3ème cas de transf_step_correct de PostpassSchedulingproof fini MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index fbb05ca2..92f5ebd4 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -303,12 +303,10 @@ Proof. inv BBEQ. rewrite H3 in H2. exists (State rs' m'). split; try (constructor; auto). eapply transf_step_simu; eauto. + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. - exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). - assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. remember (State (nextblock _ _) _) as s'. exists s'. split; try constructor; auto. @@ -318,9 +316,12 @@ Proof. all: eauto. eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - - destruct TODO. -Admitted. + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + remember (State _ m') as s'. exists s'. split; try constructor; auto. + subst s'. eapply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. +Qed. Theorem transf_program_correct: forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). -- cgit From 897d83b892df7f2e7a0a633ab7c22313c91c1bb9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 23 Jan 2019 17:25:34 +0100 Subject: Cleaning dans PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingproof.v | 63 ++++++++++++-------------------------- 1 file changed, 20 insertions(+), 43 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 92f5ebd4..4205398a 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -91,6 +91,14 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. +Lemma verified_schedule_builtin_idem: + forall bi ef args res lbb, + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bi = OK lbb -> + lbb = bi :: nil. +Proof. +Admitted. + Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> @@ -113,6 +121,18 @@ Lemma concat_all_size : Proof. Admitted. +Lemma concat_all_equiv_cons: + forall tge tf bb lbb tbb rs m rs'' m'', + concat_all (bb::lbb) = OK tbb -> + exec_bblock tge tf tbb rs m = Next rs'' m'' -> + exists tbb' rs' m', + exec_bblock tge tf bb rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) + /\ concat_all lbb = OK tbb' + /\ exec_bblock tge tf tbb' rs' m' = Next rs'' m''. +Proof. +Admitted. + Lemma ptrofs_add_repr : forall a b, Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). @@ -122,27 +142,6 @@ Proof. rewrite <- Zplus_mod. auto. Qed. -Theorem concat_exec_straight (ge: Genv.t fundef unit) (f: function) : - forall lbb bb rs m rs' m' c, - concat_all lbb = OK bb -> - exec_bblock ge f bb rs m = Next rs' m' -> - rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) -> - exec_straight_blocks ge f (lbb++c) rs m c rs' m'. -Proof. - induction lbb; try discriminate. - intros until c. intros CONC EXEB. - destruct lbb as [| b lbb]. - - simpl in CONC. inv CONC. simpl. econstructor; eauto. - - exploit concat_exec_bblock_nonil; eauto; try discriminate. - intros (bb' & rs0 & m0 & CONC' & EXEB0 & PCeq & EXEB1). intros PCeq'. - eapply exec_straight_blocks_trans; eauto. - instantiate (3 := (b :: lbb) ++ c). - econstructor; eauto. - eapply IHlbb; eauto. - rewrite PCeq. rewrite Val.offset_ptr_assoc. - erewrite concat_all_size in PCeq'; eauto. -Admitted. (* FIXME - attention à l'hypothèse rs' PC qui n'est pas forcément vraie *) - Section PRESERVATION. Variables prog tprog: program. @@ -242,28 +241,6 @@ Lemma transf_exec_bblock: Proof. Admitted. -Axiom TODO: False. - -Lemma concat_all_equiv_cons: - forall tge tf bb lbb tbb rs m rs'' m'', - concat_all (bb::lbb) = OK tbb -> - exec_bblock tge tf tbb rs m = Next rs'' m'' -> - exists tbb' rs' m', - exec_bblock tge tf bb rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) - /\ concat_all lbb = OK tbb' - /\ exec_bblock tge tf tbb' rs' m' = Next rs'' m''. -Proof. -Admitted. - -Lemma verified_schedule_builtin_idem: - forall bi ef args res lbb, - exit bi = Some (PExpand (Pbuiltin ef args res)) -> - verified_schedule bi = OK lbb -> - lbb = bi :: nil. -Proof. -Admitted. - Lemma transf_step_simu: forall tf b lbb ofs c tbb rs m rs' m', Genv.find_funct_ptr tge b = Some (Internal tf) -> -- cgit From e83e59892faf15d4d150761de75633a3624b2126 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 24 Jan 2019 12:00:58 +0100 Subject: Un peu d'avancement sur PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingproof.v | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 4205398a..fe3c07eb 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -41,11 +41,12 @@ Proof. - discriminate. Qed. -Lemma app_nonil2 {A: Type} : forall (l': list A) l, l' <> nil -> l ++ l' <> nil. +Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. Proof. - induction l'; try contradiction. - intros. cutrewrite (l ++ a :: l' = (l ++ a :: nil) ++ l'). apply app_nonil. -Admitted. + destruct l. + - intros. simpl; auto. + - intros. rewrite <- app_comm_cons. discriminate. +Qed. Program Definition concat2 (bb bb': bblock) : res bblock := match (exit bb) with @@ -91,14 +92,31 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. -Lemma verified_schedule_builtin_idem: - forall bi ef args res lbb, - exit bi = Some (PExpand (Pbuiltin ef args res)) -> - verified_schedule bi = OK lbb -> - lbb = bi :: nil. +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 verified_schedule_single_inst: + forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). Proof. Admitted. +Lemma verified_schedule_builtin_idem: + forall bb ef args res lbb, + exit bb = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bb = OK lbb -> + lbb = bb :: nil. +Proof. + intros. exploit builtin_body_nil; eauto. intros. + rewrite verified_schedule_single_inst in H0. + - inv H0. auto. + - unfold size. rewrite H. rewrite H1. simpl. auto. +Qed. + Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> -- cgit From 0e2080919f53ff40276c6aa1f253a591a89ec917 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 25 Jan 2019 11:25:16 +0100 Subject: Progrès dans PostpassSchedulingproof MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 52 +++++++++++++++++++++++++++++++++----- 1 file changed, 46 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index fe3c07eb..56662a0a 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -92,6 +92,8 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. +Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). + Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. @@ -100,11 +102,6 @@ Proof. eapply H1; eauto. Qed. -Lemma verified_schedule_single_inst: - forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). -Proof. -Admitted. - Lemma verified_schedule_builtin_idem: forall bb ef args res lbb, exit bb = Some (PExpand (Pbuiltin ef args res)) -> @@ -117,6 +114,45 @@ Proof. - unfold size. rewrite H. rewrite H1. simpl. auto. Qed. +Lemma concat2_noexit: + forall a b bb, + concat2 a b = OK bb -> + exit a = None. +Proof. + intros. destruct a as [hd bdy ex WF]; simpl in *. + destruct ex as [e|]; simpl in *; auto. + unfold concat2 in H. simpl in H. discriminate. +Qed. + +Lemma concat2_decomp: + forall a b bb, + concat2 a b = OK bb -> + body bb = body a ++ body b + /\ exit bb = exit b. +Proof. + intros. exploit concat2_noexit; eauto. intros. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. + subst exa. + unfold concat2 in H; simpl in H. + destruct hdb. +Admitted. + +Lemma concat2_straight: + forall a b bb rs m rs'' m'' f ge, + concat2 a b = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists rs' m', + exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f b rs' m' = Next rs'' m''. +Proof. + intros. + + + apply concat2_noexit in H. destruct a as [hd bdy ex WF]. simpl in *. subst ex. + repeat eexists. unfold exec_bblock. simpl. +Admitted. + Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> @@ -128,9 +164,13 @@ Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. Proof. - + intros until m''. intros Hnonil CONC EXEB. + simpl in CONC. + destruct lbb as [|b lbb]; try contradiction. clear Hnonil. + monadInv CONC. exists x. Admitted. + Lemma concat_all_size : forall a lbb bb bb', concat_all (a :: lbb) = OK bb -> -- cgit From e61639d96fdeb361188a9a93e5d0648f0386a849 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 25 Jan 2019 15:29:32 +0100 Subject: Avancement PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingproof.v | 74 +++++++++++++++++++++++++++++++++++--- 1 file changed, 69 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 56662a0a..ef9f5f0d 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -16,6 +16,7 @@ Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. Require Import Asmblockgenproof0. Require Import PostpassScheduling. +Require Import Asmblockgenproof. Local Open Scope error_monad_scope. @@ -135,7 +136,64 @@ Proof. subst exa. unfold concat2 in H; simpl in H. destruct hdb. -Admitted. + - destruct exb. + + destruct c. + * destruct i. discriminate. + * monadInv H. split; auto. + + monadInv H. split; auto. + - discriminate. +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 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 *. exploreInst. + - inv H. unfold exec_arith_instr. exploreInst. Search (_ # _ <- _). +Qed. + +Lemma exec_body_pc_var: + forall l ge rs m rs' m' v, + exec_body ge l rs m = Next rs' m' -> + exec_body ge l (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + induction l. + - intros. simpl. simpl in H. inv H. auto. + - intros. simpl in *. + destruct (exec_basic_instr ge a rs m) eqn:EXEBI. + + +Qed. *) + Lemma concat2_straight: forall a b bb rs m rs'' m'' f ge, @@ -147,12 +205,18 @@ Lemma concat2_straight: /\ exec_bblock ge f b rs' m' = Next rs'' m''. Proof. intros. - - - apply concat2_noexit in H. destruct a as [hd bdy ex WF]. simpl in *. subst ex. - repeat eexists. unfold exec_bblock. simpl. + exploit concat2_noexit; eauto. intros. + exploit concat2_decomp; eauto. intros. inv H2. +(* destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]. *) + unfold exec_bblock in H0. destruct (exec_body ge (body bb) rs m) eqn:EXEB. + - rewrite H3 in EXEB. apply exec_body_app in EXEB. destruct EXEB as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. + unfold exec_bblock. rewrite EXEB1. rewrite H1. simpl. eauto. + exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H2. auto. + unfold exec_bblock. Admitted. + Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> -- cgit From 88a8995fbbb9242d1f97110e79badd608dd03f6b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 27 Jan 2019 19:16:08 +0100 Subject: give meaningful messages please --- mppa_k1c/Asmexpand.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index de75df25..b6962bdc 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -529,8 +529,18 @@ let expand_instruction instr = expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr - *)| _ -> - assert false + *) + | EF_memcpy _ -> failwith "asmexpand: memcpy" + | EF_malloc -> failwith "asmexpand: malloc" + | EF_free -> failwith "asmexpand: free" + | EF_vload _ -> failwith "asmexpand: vload" + | EF_vstore _ -> failwith "asmexpand: vstore" + | EF_debug _ -> failwith "asmexpand: debug" + | EF_annot _ -> failwith "asmexpand: annot" + | EF_annot_val _ -> failwith "asmexpand: annot_val" + | EF_external _ -> failwith "asmexpand: external" + | EF_inline_asm _ -> failwith "asmexpand: inline asm" + | EF_runtime _ -> failwith "asmexpand: runtime" end | _ -> emit instr -- cgit From ba51ef8f74a36501574ca44c664fec2736b4a724 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 28 Jan 2019 17:53:46 +0100 Subject: Avancement sur exec_basic_instr_pcvar + exec_load et exec_store prennent des ireg au lieu de preg --- mppa_k1c/Asmblock.v | 4 +- mppa_k1c/Asmblockgenproof1.v | 78 ++++++++++-------- mppa_k1c/PostpassSchedulingproof.v | 165 +++++++++++++++++++++++++++++-------- 3 files changed, 179 insertions(+), 68 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 14ceb082..282723f1 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -958,14 +958,14 @@ Definition eval_offset (ofs: offset) : ptrofs := end. Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) - (d: preg) (a: ireg) (ofs: offset) := + (d: ireg) (a: ireg) (ofs: offset) := match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with | None => Stuck | Some v => Next (rs#d <- v) m end. Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) - (s: preg) (a: ireg) (ofs: offset) := + (s: ireg) (a: ireg) (ofs: offset) := match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with | None => Stuck | Some m' => Next rs m' diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 02301161..bf3be247 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1318,13 +1318,13 @@ Lemma indexed_load_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge 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 -> - base <> RTMP -> rd <> PC -> + base <> RTMP -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m /\ rs'#rd = v /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. Proof. - intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. + intros until m; intros EXEC; intros until v; intros LOAD NOT31. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & A & B & C). econstructor; split. @@ -1339,18 +1339,22 @@ Lemma indexed_store_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> RTMP -> r1 <> RTMP -> r1 <> PC -> + base <> RTMP -> r1 <> RTMP -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. - intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31'. exploit indexed_memory_access_correct. instantiate (1 := base). eauto. intros (base' & ofs' & rs' & A & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite B, C, STORE. eauto. eauto. auto. - intros; Simpl. rewrite C; auto. + unfold exec_store. rewrite B, C, STORE. + eauto. + discriminate. + { intro. inv H. contradiction. } + auto. +(* intros; Simpl. rewrite C; auto. *) Qed. Lemma loadind_correct: @@ -1364,14 +1368,15 @@ Lemma loadind_correct: /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR LOAD NOT31. - assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs :: k + assert (A: exists mk_instr rd, + preg_of dst = IR rd + /\ 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 ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). + exec_load ge (chunk_of_type ty) rs' m rd base' ofs'). { unfold loadind in TR. - destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } - destruct A as (mk_instr & B & C). subst c. + destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } + destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. eapply indexed_load_access_correct; eauto with asmgen. Qed. @@ -1385,14 +1390,17 @@ Lemma storeind_correct: /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR STORE NOT31. - assert (A: exists mk_instr, - c = indexed_memory_access mk_instr base ofs :: k + assert (A: exists mk_instr rr, + preg_of src = IR rr + /\ c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). - { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } - destruct A as (mk_instr & B & C). subst c. - eapply indexed_store_access_correct; eauto with asmgen. + exec_store ge (chunk_of_type ty) rs' m rr base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; esplit; eauto. } + destruct A as (mk_instr & rr & rsEq & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. + congruence. + destruct rr; try discriminate. destruct src; try discriminate. Qed. Ltac bsimpl := unfold exec_bblock; simpl. @@ -1492,13 +1500,12 @@ Lemma transl_load_access_correct: 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' -> - rd <> PC -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#rd = v' /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. Proof. - intros until v'; intros INSTR TR EV LOAD NOTPC. + intros until v'; intros INSTR TR EV LOAD. exploit transl_memory_access_correct; eauto. intros (base & ofs & rs' & A & B & C). econstructor; split. @@ -1514,17 +1521,19 @@ Lemma transl_store_access_correct: 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.storev chunk m v rs#r1 = Some m' -> - r1 <> PC -> r1 <> RTMP -> + r1 <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. - intros until m'; intros INSTR TR EV STORE NOTPC NOT31. + intros until m'; intros INSTR TR EV STORE NOT31. exploit transl_memory_access_correct; eauto. intros (base & ofs & rs' & A & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. + rewrite INSTR. unfold exec_store. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. Qed. Lemma transl_load_correct: @@ -1538,12 +1547,13 @@ Lemma transl_load_correct: /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR EV LOAD. - assert (A: exists mk_instr, - transl_memory_access mk_instr addr args k = OK c + assert (A: 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 ge chunk rs m (preg_of dst) base ofs). - { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } - destruct A as (mk_instr & B & C). + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs). + { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (esplit; eauto). } + destruct A as (mk_instr & rd & rdEq & B & C). rewrite rdEq. eapply transl_load_access_correct; eauto with asmgen. Qed. @@ -1557,19 +1567,21 @@ Lemma transl_store_correct: /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. - assert (A: exists mk_instr chunk', - transl_memory_access mk_instr addr args k = OK c + assert (A: exists mk_instr chunk' rr, + preg_of src = IR rr + /\ 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_store ge chunk' rs m (preg_of src) base ofs) + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk' rs m rr base ofs) /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). { unfold transl_store in TR; destruct chunk; ArgsInv; - (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). + (econstructor; econstructor; econstructor; split; [eauto | split; [eassumption | split; [ intros; simpl; reflexivity | auto]]]). destruct a; auto. apply Mem.store_signed_unsigned_8. destruct a; auto. apply Mem.store_signed_unsigned_16. } - destruct A as (mk_instr & chunk' & B & C & D). + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D). rewrite D in STORE; clear D. - eapply transl_store_access_correct; eauto with asmgen. + eapply transl_store_access_correct; eauto with asmgen. congruence. + destruct rr; try discriminate. destruct src; try discriminate. Qed. Lemma make_epilogue_correct: diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index ef9f5f0d..f1a4452b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -17,6 +17,7 @@ Require Import Op Locations Machblock Conventions Asmblock. Require Import Asmblockgenproof0. Require Import PostpassScheduling. Require Import Asmblockgenproof. +Require Import Axioms. Local Open Scope error_monad_scope. @@ -173,13 +174,86 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -(* Lemma exec_basic_instr_pc_var: +Lemma next_eq {A: Type}: + forall (rs rs':A) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros. congruence. +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). +Proof. + intros. apply functional_extensionality. intros. destruct (preg_eq r x). + - subst r. repeat (rewrite Pregmap.gss; auto). + - repeat (rewrite Pregmap.gso); auto. +Qed. + +Lemma exec_load_pc_var: + forall ge t rs m rd ra ofs rs' m' v, + exec_load ge t rs m rd ra ofs = Next rs' m' -> + exec_load ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load 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_store_pc_var: + forall ge t rs m rd ra ofs rs' m' v, + exec_store ge t rs m rd ra ofs = Next rs' m' -> + exec_store ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store 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 *. exploreInst. - - inv H. unfold exec_arith_instr. exploreInst. Search (_ # _ <- _). + intros. unfold exec_basic_instr in *. destruct i. + - unfold exec_arith_instr in *. exploreInst. + all: try (inv H; apply next_eq; auto; + apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). + - exploreInst; apply exec_load_pc_var; auto. + - exploreInst; apply exec_store_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 GPR14 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: @@ -190,10 +264,23 @@ Proof. induction l. - intros. simpl. simpl in H. inv H. auto. - intros. simpl in *. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI. - + -Qed. *) + destruct (exec_basic_instr ge a rs m) eqn:EXEBI; try discriminate. + erewrite exec_basic_instr_pc_var; eauto. +Qed. + +Axiom TODO: False. +Lemma pc_set_add: + forall rs v r x y, + rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). +Proof. + intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). + - subst. repeat (rewrite Pregmap.gss); auto. + destruct v; simpl; auto. + rewrite Ptrofs.add_assoc. + destruct TODO. + - repeat (rewrite Pregmap.gso; auto). +Admitted. Lemma concat2_straight: forall a b bb rs m rs'' m'' f ge, @@ -208,16 +295,22 @@ Proof. exploit concat2_noexit; eauto. intros. exploit concat2_decomp; eauto. intros. inv H2. (* destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]. *) - unfold exec_bblock in H0. destruct (exec_body ge (body bb) rs m) eqn:EXEB. - - rewrite H3 in EXEB. apply exec_body_app in EXEB. destruct EXEB as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. - unfold exec_bblock. rewrite EXEB1. rewrite H1. simpl. eauto. - exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H2. auto. - unfold exec_bblock. -Admitted. - + unfold exec_bblock in H0. destruct (exec_body ge (body bb) rs m) eqn:EXEB; try discriminate. + rewrite H3 in EXEB. apply exec_body_app in EXEB. destruct EXEB as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. + unfold exec_bblock. rewrite EXEB1. rewrite H1. simpl. eauto. + exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H2. auto. + unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. + rewrite <- H4. unfold nextblock in H0. rewrite regset_double_set_id. + assert (size bb = size a + size b). + { unfold size. rewrite H3. rewrite H4. rewrite app_length. rewrite H1. simpl. rewrite Nat.add_0_r. + repeat (rewrite Nat2Z.inj_add). omega. } + clear H1 H3 H4. rewrite H2 in H0. + assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } + rewrite H1. rewrite <- pc_set_add. auto. +Qed. -Lemma concat_exec_bblock_nonil (ge: Genv.t fundef unit) (f: function) : +Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> concat_all (a :: lbb) = OK bb -> @@ -231,29 +324,33 @@ Proof. intros until m''. intros Hnonil CONC EXEB. simpl in CONC. destruct lbb as [|b lbb]; try contradiction. clear Hnonil. - monadInv CONC. exists x. -Admitted. + monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). + exists x. repeat econstructor. all: eauto. +Qed. +Lemma concat2_size: + forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. +Proof. + intros. unfold concat2 in H. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. + destruct exa; try discriminate. destruct hdb; try discriminate. destruct exb; try discriminate. + - destruct c. + + destruct i; try discriminate. + + inv H. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. + - inv H. unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. +Qed. Lemma concat_all_size : - forall a lbb bb bb', + forall lbb a bb bb', concat_all (a :: lbb) = OK bb -> concat_all lbb = OK bb' -> size bb = size a + size bb'. Proof. -Admitted. - -Lemma concat_all_equiv_cons: - forall tge tf bb lbb tbb rs m rs'' m'', - concat_all (bb::lbb) = OK tbb -> - exec_bblock tge tf tbb rs m = Next rs'' m'' -> - exists tbb' rs' m', - exec_bblock tge tf bb rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) - /\ concat_all lbb = OK tbb' - /\ exec_bblock tge tf tbb' rs' m' = Next rs'' m''. -Proof. -Admitted. + intros. unfold concat_all in H. fold concat_all in H. + destruct lbb; try discriminate. + monadInv H. rewrite H0 in EQ. inv EQ. + apply concat2_size. assumption. +Qed. Lemma ptrofs_add_repr : forall a b, @@ -376,8 +473,10 @@ Proof. induction lbb. - intros until m'. simpl. intros. discriminate. - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. - exploit concat_all_equiv_cons; eauto. - intros (tbb0 & rs0 & m0 & EXEB0 & PCeq' & CONC0 & EXEB1). + destruct lbb. + + simpl in *. clear IHlbb. inv CONC. eapply plus_one. econstructor; eauto. eapply find_bblock_tail; eauto. + + exploit concat_all_exec_bblock; eauto; try discriminate. + intros (tbb0 & rs0 & m0 & CONC0 & EXEB0 & PCeq' & EXEB1). eapply plus_left. econstructor. 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. -- cgit From 61bd09baee35a8acc68cd4047eb811839b59e945 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 29 Jan 2019 17:02:35 +0100 Subject: Hypothèses de pc_set_add permettant de prouver le lemme MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 45 ++++++++++++++++++++++---------------- 1 file changed, 26 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f1a4452b..35936303 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -268,22 +268,26 @@ Proof. erewrite exec_basic_instr_pc_var; eauto. Qed. -Axiom TODO: False. - Lemma pc_set_add: forall rs v r x y, + 0 <= x <= Ptrofs.max_unsigned -> + 0 <= y <= Ptrofs.max_unsigned -> rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). Proof. intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). - subst. repeat (rewrite Pregmap.gss); auto. destruct v; simpl; auto. rewrite Ptrofs.add_assoc. - destruct TODO. + cutrewrite (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)); auto. + unfold Ptrofs.add. + cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. + repeat (rewrite Ptrofs.unsigned_repr); auto. - repeat (rewrite Pregmap.gso; auto). -Admitted. +Qed. Lemma concat2_straight: forall a b bb rs m rs'' m'' f ge, + size a <= Ptrofs.max_unsigned -> size b <= Ptrofs.max_unsigned -> concat2 a b = OK bb -> exec_bblock ge f bb rs m = Next rs'' m'' -> exists rs' m', @@ -291,27 +295,30 @@ Lemma concat2_straight: /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) /\ exec_bblock ge f b rs' m' = Next rs'' m''. Proof. - intros. - exploit concat2_noexit; eauto. intros. - exploit concat2_decomp; eauto. intros. inv H2. -(* destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]. *) - unfold exec_bblock in H0. destruct (exec_body ge (body bb) rs m) eqn:EXEB; try discriminate. - rewrite H3 in EXEB. apply exec_body_app in EXEB. destruct EXEB as (rs1 & m1 & EXEB1 & EXEB2). + intros until ge. intros LTA LTB CONC2 EXEB. + exploit concat2_noexit; eauto. intros EXA. + exploit concat2_decomp; eauto. intros. inv H. + unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. + rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). repeat eexists. - unfold exec_bblock. rewrite EXEB1. rewrite H1. simpl. eauto. - exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H2. auto. + unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. + exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. - rewrite <- H4. unfold nextblock in H0. rewrite regset_double_set_id. + rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. assert (size bb = size a + size b). - { unfold size. rewrite H3. rewrite H4. rewrite app_length. rewrite H1. simpl. rewrite Nat.add_0_r. + { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. repeat (rewrite Nat2Z.inj_add). omega. } - clear H1 H3 H4. rewrite H2 in H0. + clear EXA H0 H1. rewrite H in EXEB. assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } - rewrite H1. rewrite <- pc_set_add. auto. + rewrite H0. rewrite <- pc_set_add; auto. + exploit AB.size_positive. instantiate (1 := a). intro. omega. + exploit AB.size_positive. instantiate (1 := b). intro. omega. Qed. +Axiom TODO: False. + Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : - forall a bb rs m lbb rs'' m'', + forall a bb rs m lbb rs'' m'', lbb <> nil -> concat_all (a :: lbb) = OK bb -> exec_bblock ge f bb rs m = Next rs'' m'' -> @@ -324,9 +331,9 @@ Proof. intros until m''. intros Hnonil CONC EXEB. simpl in CONC. destruct lbb as [|b lbb]; try contradiction. clear Hnonil. - monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). + monadInv CONC. exploit concat2_straight; eauto. 1-2: destruct TODO. intros (rs' & m' & EXEB1 & PCeq & EXEB2). exists x. repeat econstructor. all: eauto. -Qed. +Admitted. Lemma concat2_size: forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. -- cgit From 0a693ac9dd3b181ba42566996531438ef205815c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 25 Jan 2019 17:53:48 +0100 Subject: Adding indirect calls (icall instruction) --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 3 +++ mppa_k1c/Asmblockgen.v | 6 +++--- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++--- mppa_k1c/TargetPrinter.ml | 2 ++ 6 files changed, 36 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index eef5f39c..0f6f2b8b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -59,6 +59,7 @@ Inductive instruction : Type := | 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 *) | Pj_l (l: label) (**r jump to label *) @@ -156,6 +157,7 @@ Definition control_to_instruction (c: control) := | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res | PCtlFlow Asmblock.Pret => Pret | PCtlFlow (Asmblock.Pcall l) => Pcall l + | PCtlFlow (Asmblock.Picall r) => Picall r | PCtlFlow (Asmblock.Pgoto l) => Pgoto l | PCtlFlow (Asmblock.Pj_l l) => Pj_l l | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 282723f1..300ab0fc 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -220,6 +220,7 @@ table: .long table[0], table[1], ... Inductive cf_instruction : Type := | Pret (**r return *) | Pcall (l: label) (**r function call *) + | Picall (r: ireg) (**r function call on register value *) (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) | Pgoto (l: label) (**r goto *) @@ -1148,6 +1149,8 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) Next (rs#PC <- (rs#RA)) m | Pcall s => Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + | Picall r => + Next (rs#RA <- (rs#PC) #PC <- (rs#r)) m | Pgoto s => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m | Pj_l l => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e32748f8..d051697f 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -789,9 +789,9 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co | None => OK nil | Some i => match i with -(*| Mcall sig (inl r) => - do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) -*) | MBcall sig (inr symb) => + | MBcall sig (inl r) => + do r1 <- ireg_of r; OK ((Picall r1) ::g nil) + | MBcall sig (inr symb) => OK ((Pcall symb) ::g nil) (*| Mtailcall sig (inl r) => do r1 <- ireg_of r; diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 686e8349..5a3ab5e1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1162,7 +1162,27 @@ Proof. 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 *) inv H1. + * (* 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. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 4d7c8636..5c155540 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -159,6 +159,7 @@ let expand_rec = function 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} | 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} @@ -332,7 +333,7 @@ type real_instruction = | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd (* BCU *) - | Call | Cb | Goto | Ret | Get | Set + | Icall | Call | Cb | Goto | Ret | Get | Set (* FPU *) | Fnegd @@ -376,6 +377,7 @@ let ab_inst_to_real = function | "Pcb" | "Pcbu" -> Cb | "Pcall" -> Call + | "Picall" -> Icall | "Pgoto" | "Pj_l" -> Goto | "Pget" -> Get | "Pret" -> Ret @@ -428,7 +430,7 @@ let rec_to_usage r = (match encoding with None | Some U6 | Some S10 -> lsu_acc | Some U27L5 | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) - | Call | Cb | Goto | Ret | Set -> bcu + | Icall | Call | Cb | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop | Fnegd -> alu_lite @@ -444,7 +446,7 @@ let real_inst_to_latency = function -> 3 (* FIXME - random value *) | Get -> 1 | Set -> 3 - | Call | Cb | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) + | Icall | Call | Cb | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) | Fnegd -> 1 let rec_to_info r : inst_info = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 36fab151..0d357962 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -237,6 +237,8 @@ module Target (*: TARGET*) = fprintf oc " ret \n" | Pcall(s) -> fprintf oc " call %a\n" symbol s + | Picall(rs) -> + fprintf oc " icall %a\n" ireg rs | Pgoto(s) -> fprintf oc " goto %a\n" symbol s | Pj_l(s) -> -- cgit From 295ea9f535cef2b874823680008c712a3f40d69b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 29 Jan 2019 20:31:38 +0100 Subject: give meaningful "unhandled instr" messages --- mppa_k1c/Asmblockgen.v | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index d051697f..214801f5 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -793,25 +793,21 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co do r1 <- ireg_of r; OK ((Picall r1) ::g nil) | MBcall sig (inr symb) => OK ((Pcall symb) ::g nil) -(*| Mtailcall sig (inl r) => - do r1 <- ireg_of r; - OK (make_epilogue f (Pcall :: k)) -*) | MBtailcall sig (inr symb) => + | MBtailcall sig (inr symb) => OK (make_epilogue f ((Pgoto symb) ::g nil)) | MBbuiltin ef args res => OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) -(* | Mlabel lbl => - OK (Plabel lbl ::i k) *) | MBgoto lbl => OK (Pj_l lbl ::g nil) | MBcond cond args lbl => transl_cbranch cond args lbl nil -(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) -*) | MBreturn => + | MBreturn => OK (make_epilogue f (Pret ::g nil)) - (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) - | _ => - Error (msg "Asmgenblock.transl_instr") + (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) + | MBtailcall _ (inl _) => + Error (msg "Asmgenblock.transl_instr_control MBtailcall inl") + | MBjumptable _ _ => + Error (msg "Asmgenblock.transl_instr_control MBjumptable") end end. -- cgit From a5da25f1c04f4bc3ef70930053282fd9de4040d5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 30 Jan 2019 09:45:17 +0100 Subject: synchronized with David's scheduling work --- mppa_k1c/InstructionScheduler.ml | 265 +++++++++++++++++++++++++++++++++----- mppa_k1c/InstructionScheduler.mli | 21 ++- 2 files changed, 249 insertions(+), 37 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index ae4296a2..b335aab5 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -11,7 +11,22 @@ type problem = { resource_bounds : int array; instruction_usages : int array array; latency_constraints : latency_constraint list; - } + };; + +let print_problem channel problem = + (if problem.max_latency >= 0 + then Printf.fprintf channel "max makespan: %d\n" problem.max_latency); + output_string channel "resource bounds:"; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) problem.resource_bounds); + output_string channel ";\n"; + (Array.iteri (fun i v -> + Printf.fprintf channel "instr%d:" i; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) v); + output_string channel ";\n") problem.instruction_usages); + List.iter (fun instr -> + Printf.printf "t%d - t%d >= %d;\n" + instr.instr_to instr.instr_from instr.latency) + problem.latency_constraints;; let get_nr_instructions problem = Array.length problem.instruction_usages;; let get_nr_resources problem = Array.length problem.resource_bounds;; @@ -88,7 +103,7 @@ let vector_subtract a b = (* The version with critical path ordering is much better! *) type list_scheduler_order = - (* | INSTRUCTION_ORDER *) + | INSTRUCTION_ORDER | CRITICAL_PATH_ORDER;; let int_max (x : int) (y : int) = @@ -134,10 +149,9 @@ let critical_paths successors = done; path_lengths;; -(* let maximum_critical_path problem = +let maximum_critical_path problem = let paths = critical_paths (get_successors problem) in Array.fold_left int_max 0 paths;; -*) let get_earliest_dates predecessors = let nr_instructions = (Array.length predecessors)-1 in @@ -186,7 +200,7 @@ let priority_list_scheduler (order : list_scheduler_order) and times = Array.make (nr_instructions+1) (-1) in let priorities = match order with - (* | INSTRUCTION_ORDER -> None *) + | INSTRUCTION_ORDER -> None | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in let module InstrSet = @@ -293,6 +307,10 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; +(* FIXME DUMMY CODE to placate warnings + *) +let _ = priority_list_scheduler INSTRUCTION_ORDER;; + (* alternate implementation let swap_array_elements a i j = let x = a.(i) in @@ -412,13 +430,15 @@ type pseudo_boolean_mapper = { (* Latency constraints are: presence of instr-to at each t <= sum of presences of instr-from at compatible times - if dual_encoding + if reverse_encoding presence of instr-from at each t <= sum of presences of instr-to at compatible times *) -(* Experiments show dual_encoding=true multiplies time by 2 +(* Experiments show reverse_encoding=true multiplies time by 2 in sat4j without making hard instances easier *) -let dual_encoding = false - +let direct_encoding = false +and reverse_encoding = false +and delta_encoding = true + let pseudo_boolean_print_problem channel problem pb_type = let deadline = problem.max_latency in assert (deadline > 0); @@ -470,7 +490,7 @@ let pseudo_boolean_print_problem channel problem pb_type = if ctr.instr_to < nr_instructions then count := !count + 1 + latest_dates.(ctr.instr_to) - earliest_dates.(ctr.instr_to) - + (if dual_encoding + + (if reverse_encoding then 1 + latest_dates.(ctr.instr_from) - earliest_dates.(ctr.instr_from) else 0) @@ -580,7 +600,7 @@ let pseudo_boolean_print_problem channel problem pb_type = do gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to done; - if dual_encoding + if reverse_encoding then for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) do @@ -630,21 +650,21 @@ let line_to_pb_solution sol line nr_pb_variables = List.iter begin function "" -> () - | item -> - (match String.get item 0 with - | '+' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Positive - | '-' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Negative - | 'x' -> - assert ((String.length item) >= 2); - assign (String.sub item 1 ((String.length item)-1)) Positive - | c -> failwith @@ Printf.sprintf "line_to_pb_solution: unrecognized character: %c" c - ) + | item -> + (match String.get item 0 with + | '+' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Positive + | '-' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Negative + | 'x' -> + assert ((String.length item) >= 2); + assign (String.sub item 1 ((String.length item)-1)) Positive + | _ -> failwith "syntax error in pseudo Boolean solution: epected + - or x" + ) end (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; @@ -734,12 +754,13 @@ let adjust_check_solution mapper solution = (* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) (* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) (* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) - -let pseudo_boolean_solver = ref "java -jar /opt/sat4j/sat4j-pb.jar CuttingPlanesStar" +(* let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" *) +let pseudo_boolean_solver = ref "pb_solver" let pseudo_boolean_scheduler pb_type problem = try - let filename_in = "problem.opb" (* and filename_out = "problem.sol" *) in + let filename_in = "problem.opb" + (* needed only if not using stdout and filename_out = "problem.sol" *) in let opb_problem = open_out filename_in in let mapper = pseudo_boolean_print_problem opb_problem problem pb_type in close_out opb_problem; @@ -752,7 +773,7 @@ let pseudo_boolean_scheduler pb_type problem = | Unschedulable -> None;; let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = - if (get_max_latency previous_solution) > 1 then + if (get_max_latency previous_solution)>1 then begin Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); flush stdout; @@ -763,7 +784,7 @@ let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solu | Some solution -> reoptimizing_scheduler scheduler solution problem end else previous_solution;; - + let cascaded_scheduler (problem : problem) = match validated_scheduler list_scheduler problem with | None -> None @@ -773,7 +794,7 @@ let cascaded_scheduler (problem : problem) = let latency2 = get_max_latency solution and latency1 = get_max_latency initial_solution in if latency2 < latency1 - then Printf.printf "%d < %d\n" 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" @@ -874,3 +895,183 @@ let smt_print_problem channel problem = done; output_string channel "(check-sat)(get-model)\n";; + +let ilp_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + + let pb_var i t = + Printf.sprintf "x%d_%d" i t in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + Printf.fprintf channel "c_%d_%d_%d_%d: " + i_to i_from latency t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + output_string channel ">= 0\n" + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + Printf.fprintf channel "d_%d_%d_%d_%d: " + i_to i_from latency t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0\n" + + and gen_delta_constraint i_from i_to latency = + if delta_encoding + then Printf.fprintf channel "l_%d_%d_%d: +1 t%d -1 t%d >= %d\n" + i_from i_to latency i_to i_from latency + + in + + Printf.fprintf channel "\\ nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> output_string channel "Minimize dummy: 0\n" + | OPTIMIZATION -> + Printf.fprintf channel "Minimize\nmakespan: t%d\n" nr_instructions + end; + output_string channel "Subject To\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "\\ t[%d] in %d..%d\ntimes%d: " i early late i; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1\n" + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "\\ resource #%d at t=%d <= %d\nr%d_%d: " j t bound j t; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d\n" (-bound) + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + gen_delta_constraint ctr.instr_from ctr.instr_to ctr.latency; + begin + if direct_encoding + then + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done + end; + begin + if reverse_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for i_from = 0 to nr_instructions -1 + do + gen_delta_constraint i_from nr_instructions final_latencies.(i_from) + done; + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "ct%d : -1 t%d" i i; + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + Printf.fprintf channel " +%d %s" t (pb_var i t) + done; + output_string channel " = 0\n" + done; + output_string channel "Bounds\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + begin + Printf.fprintf channel "%d <= t%d <= %d\n" early i late; + if true then + for t=early to late do + Printf.fprintf channel "0 <= %s <= 1\n" (pb_var i t) + done + end + done; + output_string channel "Integer\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "t%d " i + done; + output_string channel "\nBinary\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + output_string channel (pb_var i t); + output_string channel " " + done; + output_string channel "\n" + done; + output_string channel "End\n";; diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli index aea5e909..1cd286a6 100644 --- a/mppa_k1c/InstructionScheduler.mli +++ b/mppa_k1c/InstructionScheduler.mli @@ -10,24 +10,29 @@ type latency_constraint = { instr_from : int; instr_to : int; latency : int; -} - + } + (** A scheduling problem. In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. *) type problem = { - (* An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) max_latency : int; + (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) - (* An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) resource_bounds : int array; + (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) - (* At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) instruction_usages: int array array; + (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) + latency_constraints : latency_constraint list + (** The latency constraints that must be satisfied *) };; +(** Print problem for human readability. *) +val print_problem : out_channel -> problem -> unit;; + (** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) type solution = int array @@ -76,6 +81,10 @@ val validated_scheduler : scheduler -> problem -> solution option;; @return Max latency *) val get_max_latency : solution -> int;; +(** Get the length of a maximal critical path +@return Max length *) +val maximum_critical_path : problem -> int;; + (** Apply line scheduler then advanced solver @return A solution if found *) val cascaded_scheduler : problem -> solution option;; @@ -92,3 +101,5 @@ val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> soluti val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; val smt_print_problem : out_channel -> problem -> unit;; + +val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> unit;; -- cgit From 0b11ac18701bec925447bbeda92b0ceefd7a7f90 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 30 Jan 2019 15:44:04 +0100 Subject: Rajouté des erreurs plus explicites dans Asmblockgen.v MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 70 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 57 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 214801f5..fa5774ef 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -309,6 +309,10 @@ Definition transl_cond_op | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (transl_condimm_int64u c rd r1 n k) + | Ccompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompf") + | Cnotcompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompf") + | Ccompfs _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompfs") + | Cnotcompfs _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompfs") (*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_float c rd r1 r2 in @@ -326,7 +330,7 @@ Definition transl_cond_op let (insn, normal) := transl_cond_single c rd r1 r2 in OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) *)| _, _ => - Error(msg "Asmgenblock.transl_cond_op") + Error(msg "Asmblockgen.transl_cond_op") end. (** Translation of the arithmetic operation [r <- op(args)]. @@ -338,7 +342,7 @@ Definition transl_op | Omove, a1 :: nil => match preg_of res, preg_of a1 with | IR r, IR a => OK (Pmv r a ::i k) - | _ , _ => Error(msg "Asmgenblock.Omove") + | _ , _ => Error(msg "Asmgenblock.transl_op: Omove") end | Ointconst n, nil => do rd <- ireg_of res; @@ -346,6 +350,8 @@ Definition transl_op | Olongconst n, nil => do rd <- ireg_of res; OK (loadimm64 rd n ::i k) + | Ofloatconst _, _ => Error(msg "Asmblockgen.transl_op: Ofloatconst") + | Osingleconst _, _ => Error(msg "Asmblockgen.transl_op: Osingleconst") (*| Ofloatconst f, nil => do rd <- freg_of res; OK (if Float.eq_dec f Float.zero @@ -386,22 +392,24 @@ Definition transl_op | 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) + | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") + | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (*| Omulhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhw rd rs1 rs2 :: k) | Omulhu, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhuw rd rs1 rs2 :: k) -*)| Odiv, a1 :: a2 :: nil => Error(msg "32-bits division not supported yet. Please use 64-bits.") +*)| Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pdivw rd rs1 rs2 :: k) *) - | Odivu, a1 :: a2 :: nil => Error(msg "32-bits division not supported yet. Please use 64-bits.") + | Odivu, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odivu: 32-bits division not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pdivuw rd rs1 rs2 :: k) *) - | Omod, a1 :: a2 :: nil => Error(msg "32-bits modulo not supported yet. Please use 64-bits.") + | Omod, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Omod: 32-bits modulo not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Premw rd rs1 rs2 :: k) *) - | Omodu, a1 :: a2 :: nil => Error(msg "32-bits modulo not supported yet. Please use 64-bits.") + | Omodu, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Omodu: 32-bits modulo not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Premuw rd rs1 rs2 :: k) *) | Oand, a1 :: a2 :: nil => @@ -475,6 +483,12 @@ Definition transl_op | 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) + | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") + | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") + | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") + | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") + | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") + | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") (*| Omullhs, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulhl rd rs1 rs2 :: k) @@ -529,6 +543,7 @@ Definition transl_op | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n ::i k) + | Oshrxlimm _, _ => Error (msg "Asmblockgen.transl_op: Oshrxlimm") (*| Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else @@ -540,6 +555,35 @@ Definition transl_op *)| Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs ::i k) + | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") + | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") + | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") + | Omulf , _ => Error (msg "Asmblockgen.transl_op: Omulf") + | Odivf , _ => Error (msg "Asmblockgen.transl_op: Odivf") + | Onegfs , _ => Error (msg "Asmblockgen.transl_op: Onegfs") + | Oabsfs , _ => Error (msg "Asmblockgen.transl_op: Oabsfs") + | Oaddfs , _ => Error (msg "Asmblockgen.transl_op: Oaddfs") + | Osubfs , _ => Error (msg "Asmblockgen.transl_op: Osubfs") + | Omulfs , _ => Error (msg "Asmblockgen.transl_op: Omulfs") + | Odivfs , _ => Error (msg "Asmblockgen.transl_op: Odivfs") + | Osingleoffloat , _ => Error (msg "Asmblockgen.transl_op: Osingleoffloat") + | Ofloatofsingle , _ => Error (msg "Asmblockgen.transl_op: Ofloatofsingle") + | Ointoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointoffloat") + | Ointuoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointuoffloat") + | Ofloatofint , _ => Error (msg "Asmblockgen.transl_op: Ofloatofint") + | Ofloatofintu , _ => Error (msg "Asmblockgen.transl_op: Ofloatofintu") + | Ointofsingle , _ => Error (msg "Asmblockgen.transl_op: Ointofsingle") + | Ointuofsingle , _ => Error (msg "Asmblockgen.transl_op: Ointuofsingle") + | Osingleofint , _ => Error (msg "Asmblockgen.transl_op: Osingleofint") + | Osingleofintu , _ => Error (msg "Asmblockgen.transl_op: Osingleofintu") + | Olongoffloat , _ => Error (msg "Asmblockgen.transl_op: Olongoffloat") + | Olonguoffloat , _ => Error (msg "Asmblockgen.transl_op: Olonguoffloat") + | Ofloatoflong , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflong") + | Ofloatoflongu , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflongu") + | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") + | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") + | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") + | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") (*| Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs :: k) @@ -662,7 +706,7 @@ Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) : | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k) | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k) | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmgenblock.loadind") + | _, _ => Error (msg "Asmblockgen.loadind") end. Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := @@ -673,7 +717,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k) | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k) | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmgenblock.storeind") + | _, _ => Error (msg "Asmblockgen.storeind") end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := @@ -696,7 +740,7 @@ Definition transl_memory_access | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs ::i k) | _, _ => - Error(msg "Asmgenblock.transl_memory_access") + Error(msg "Asmblockgen.transl_memory_access") end. Definition transl_load (chunk: memory_chunk) (addr: addressing) @@ -727,7 +771,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing) do r <- freg_of dst; transl_memory_access (Pfld r) addr args k | _ => - Error (msg "Asmgenblock.transl_load") + Error (msg "Asmblockgen.transl_load") end. Definition transl_store (chunk: memory_chunk) (addr: addressing) @@ -752,7 +796,7 @@ Definition transl_store (chunk: memory_chunk) (addr: addressing) do r <- freg_of src; transl_memory_access (Pfsd r) addr args k | _ => - Error (msg "Asmgenblock.transl_store") + Error (msg "Asmblockgen.transl_store") end. (** Function epilogue *) @@ -805,9 +849,9 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co OK (make_epilogue f (Pret ::g nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | MBtailcall _ (inl _) => - Error (msg "Asmgenblock.transl_instr_control MBtailcall inl") + Error (msg "Asmblockgen.transl_instr_control MBtailcall inl") | MBjumptable _ _ => - Error (msg "Asmgenblock.transl_instr_control MBjumptable") + Error (msg "Asmblockgen.transl_instr_control MBjumptable") end end. -- cgit From 464da1ee7861e0d51f6c5dc786907a66b0f46e35 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 31 Jan 2019 15:01:01 +0100 Subject: idee de refactoring --- mppa_k1c/PostpassScheduling.v | 78 ++++++++++++++++++++++++++++++------------- 1 file changed, 54 insertions(+), 24 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 1483a5d7..e8e6fcc5 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -21,30 +21,60 @@ Axiom schedule: bblock -> list bblock. Extract Constant schedule => "PostpassSchedulingOracle.schedule". -(* TODO - implement the verificator *) -Definition verified_schedule (bb : bblock) : res (list bblock) := OK (schedule bb). +(* TODO: refactorisation. -Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := - match lbb with - | nil => OK nil - | (cons bb lbb) => - do tlbb <- transf_blocks lbb; - do tbb <- verified_schedule bb; - OK (tbb ++ tlbb) - end. +... concat2 ... -Definition transl_function (f: function) : res function := - do lb <- transf_blocks (fn_blocks f); - OK (mkfunction (fn_sig f) lb). - -Definition transf_function (f: function) : res function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: fundef) : res fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: program) : res program := +Fixpoint concat_all (lbb: list bblock) : res bblock := + match lbb with + | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") + | bb::nil => OK bb + | bb::lbb => + do bb' <- concat_all lbb; + concat2 bb bb' + end. + +Axiom test_equiv_bblock: bblock -> bblock -> bool. + +Axiom test_equiv_bblock_correct: + forall ge f bb tbb, + test_equiv bb tbb = true -> + bblock_equiv ge f bb tbb. + +Definition verified_schedule (bb : bblock) : res (list bblock) := + DO lbb <- (schedule bb) ; + DO tbb <- (concat lbb) ; + DO res <- test_equiv_bblock bb tbb ; + if res + then OK lbb + else Error (msg "blah"). + +*) + +(* TODO - implement the verificator *) +Definition verified_schedule (bb : bblock) : res (list bblock) := OK (schedule bb). + +Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := + match lbb with + | nil => OK nil + | (cons bb lbb) => + do tlbb <- transf_blocks lbb; + do tbb <- verified_schedule bb; + OK (tbb ++ tlbb) + end. + +Definition transl_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); + OK (mkfunction (fn_sig f) lb). + +Definition transf_function (f: function) : res function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: program) : res program := transform_partial_program transf_fundef p. \ No newline at end of file -- cgit From 44cbc6d5ec1afd92203c202054dbaf9e4083aa9f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 31 Jan 2019 17:45:05 +0100 Subject: Adding a "check_size" in concat2 --- mppa_k1c/PostpassSchedulingproof.v | 43 ++++++++++++++++++++++++++------------ 1 file changed, 30 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 35936303..e66f862f 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -50,7 +50,14 @@ Proof. - intros. rewrite <- app_comm_cons. discriminate. Qed. +Definition check_size bb := + if zlt Ptrofs.max_unsigned (size bb) + then Error (msg "PostpassSchedulingproof.check_size") + else OK tt. + Program Definition concat2 (bb bb': bblock) : res bblock := + do ch <- check_size bb; + do ch' <- check_size bb'; match (exit bb) with | None => match (header bb') with @@ -78,6 +85,18 @@ Next Obligation. apply (H ef args res). contradict H1. auto. Qed. +Lemma concat2_zlt_size: + forall a b bb, + concat2 a b = OK bb -> + size a <= Ptrofs.max_unsigned + /\ size b <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. + split. + - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. + - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. +Qed. + Fixpoint concat_all (lbb: list bblock) : res bblock := match lbb with | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") @@ -123,7 +142,7 @@ Lemma concat2_noexit: Proof. intros. destruct a as [hd bdy ex WF]; simpl in *. destruct ex as [e|]; simpl in *; auto. - unfold concat2 in H. simpl in H. discriminate. + unfold concat2 in H. simpl in H. monadInv H. Qed. Lemma concat2_decomp: @@ -139,10 +158,10 @@ Proof. destruct hdb. - destruct exb. + destruct c. - * destruct i. discriminate. + * destruct i. monadInv H. * monadInv H. split; auto. + monadInv H. split; auto. - - discriminate. + - monadInv H. Qed. Lemma exec_body_app: @@ -287,7 +306,6 @@ Qed. Lemma concat2_straight: forall a b bb rs m rs'' m'' f ge, - size a <= Ptrofs.max_unsigned -> size b <= Ptrofs.max_unsigned -> concat2 a b = OK bb -> exec_bblock ge f bb rs m = Next rs'' m'' -> exists rs' m', @@ -295,7 +313,8 @@ Lemma concat2_straight: /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) /\ exec_bblock ge f b rs' m' = Next rs'' m''. Proof. - intros until ge. intros LTA LTB CONC2 EXEB. + intros until ge. intros CONC2 EXEB. + exploit concat2_zlt_size; eauto. intros (LTA & LTB). exploit concat2_noexit; eauto. intros EXA. exploit concat2_decomp; eauto. intros. inv H. unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. @@ -315,8 +334,6 @@ Proof. exploit AB.size_positive. instantiate (1 := b). intro. omega. Qed. -Axiom TODO: False. - Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : forall a bb rs m lbb rs'' m'', lbb <> nil -> @@ -331,20 +348,20 @@ Proof. intros until m''. intros Hnonil CONC EXEB. simpl in CONC. destruct lbb as [|b lbb]; try contradiction. clear Hnonil. - monadInv CONC. exploit concat2_straight; eauto. 1-2: destruct TODO. intros (rs' & m' & EXEB1 & PCeq & EXEB2). + monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). exists x. repeat econstructor. all: eauto. -Admitted. +Qed. Lemma concat2_size: forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. Proof. intros. unfold concat2 in H. destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. - destruct exa; try discriminate. destruct hdb; try discriminate. destruct exb; try discriminate. + destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). - destruct c. - + destruct i; try discriminate. - + inv H. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. - - inv H. unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. + + destruct i; try (monadInv EQ2). + + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. + - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. Qed. Lemma concat_all_size : -- cgit From b6adc00a4726538ce80a00ddff1c9b65edd1b0d8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 31 Jan 2019 18:56:14 +0100 Subject: Décomposition de transf_find_bblock en lemmes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index e66f862f..c95a8917 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -467,6 +467,23 @@ Proof. intros. inv H0. inv H. econstructor; eauto. Qed. +Lemma tail_find_bblock: + forall f ofs bb, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks f) (bb::c). +Proof. +Admitted. + +Lemma transf_blocks_verified: + forall c tc ofs bb c', + transf_blocks c = OK tc -> + code_tail (Ptrofs.unsigned ofs) c (bb::c') -> + exists lbb, + verified_schedule bb = OK lbb + /\ exists tc', code_tail (Ptrofs.unsigned ofs) tc (lbb ++ tc'). +Proof. +Admitted. + Lemma transf_find_bblock: forall ofs f bb tf, find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> @@ -475,7 +492,11 @@ Lemma transf_find_bblock: verified_schedule bb = OK lbb /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). Proof. -Admitted. + intros. + monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. + monadInv EQ. apply tail_find_bblock in H. destruct H as (c & TAIL). + eapply transf_blocks_verified; eauto. +Qed. Lemma transf_exec_bblock: forall f tf bb rs m, -- cgit From 8ae9063a94fbf3756bb2b1d596f35b81e3e608eb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 1 Feb 2019 10:04:54 +0100 Subject: implemented builtin memcpy --- mppa_k1c/Asm.v | 3 +- mppa_k1c/Asmexpand.ml | 145 ++++++++++++++++------------------------------ mppa_k1c/Machregs.v | 2 +- mppa_k1c/TargetPrinter.ml | 4 +- 4 files changed, 56 insertions(+), 98 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 0f6f2b8b..d2d562c8 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -65,6 +65,7 @@ Inductive instruction : Type := | 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 *) + | Ploopdo (count: ireg) (loopend: label) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) @@ -147,7 +148,7 @@ Inductive instruction : Type := | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) . (** Correspondance between Asmblock and Asm *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index b6962bdc..59e8c383 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -120,101 +120,57 @@ let expand_annot_val kind txt targ args res = assert false (* Handling of memcpy *) -(* Unaligned accesses are slow on RISC-V, so don't use them *) - +let stack_pointer = Asmblock.GPR12 + let offset_in_range ofs = let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L - -let memcpy_small_arg sz arg tmp = assert false -(*match arg with - | BA (IR r) -> - (r, _0) - | BA_addrstack ofs -> - if offset_in_range ofs - && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) - then (GPR12, ofs) - else begin expand_addptrofs tmp GPR12 ofs; (tmp, _0) end - | _ -> - assert false -*) - -let expand_builtin_memcpy_small sz al src dst = assert false -(*let (tsrc, tdst) = - if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in - let (rsrc, osrc) = memcpy_small_arg sz src tsrc in - let (rdst, odst) = memcpy_small_arg sz dst tdst in - let rec copy osrc odst sz = - if sz >= 8 && al >= 8 then - begin - emit (Pfld (F0, rsrc, Ofsimm osrc)); - emit (Pfsd (F0, rdst, Ofsimm odst)); - copy (Ptrofs.add osrc _8) (Ptrofs.add odst _8) (sz - 8) - end - else if sz >= 4 && al >= 4 then - begin - emit (Plw (X31, rsrc, Ofsimm osrc)); - emit (Psw (X31, rdst, Ofsimm odst)); - copy (Ptrofs.add osrc _4) (Ptrofs.add odst _4) (sz - 4) - end - else if sz >= 2 && al >= 2 then - begin - emit (Plh (X31, rsrc, Ofsimm osrc)); - emit (Psh (X31, rdst, Ofsimm odst)); - copy (Ptrofs.add osrc _2) (Ptrofs.add odst _2) (sz - 2) - end - else if sz >= 1 then - begin - emit (Plb (X31, rsrc, Ofsimm osrc)); - emit (Psb (X31, rdst, Ofsimm odst)); - copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1) - end - in copy osrc odst sz -*) - -let memcpy_big_arg sz arg tmp = assert false -(*match arg with - | BA (IR r) -> if r <> tmp then emit (Pmv(tmp, r)) - | BA_addrstack ofs -> - expand_addptrofs tmp X2 ofs - | _ -> - assert false -*) - -let expand_builtin_memcpy_big sz al src dst = assert false -(*assert (sz >= al); - assert (sz mod al = 0); - let (s, d) = - if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in - memcpy_big_arg sz src s; - memcpy_big_arg sz dst d; - (* Use X7 as loop count, X1 and F0 as ld/st temporaries. *) - let (load, store, chunksize) = - if al >= 8 then - (Pfld (F0, s, Ofsimm _0), Pfsd (F0, d, Ofsimm _0), 8) - else if al >= 4 then - (Plw (X31, s, Ofsimm _0), Psw (X31, d, Ofsimm _0), 4) - else if al = 2 then - (Plh (X31, s, Ofsimm _0), Psh (X31, d, Ofsimm _0), 2) - else - (Plb (X31, s, Ofsimm _0), Psb (X31, d, Ofsimm _0), 1) in - expand_loadimm32 X7 (Z.of_uint (sz / chunksize)); - let delta = Z.of_uint chunksize in - let lbl = new_label () in - emit (Plabel lbl); - emit load; - expand_addptrofs s s delta; - emit (Paddiw(X7, X X7, _m1)); - emit store; - expand_addptrofs d d delta; - emit (Pbnew (X X7, X0, lbl)) -*) +let emit_move dst r = + if dst <> r + then emit (Paddil(dst, r, Z.zero));; + +(* FIXME DMonniaux this is probably not complete *) +let get_builtin_arg dst arg = + match arg with + | BA (Asmblock.IR reg) -> emit_move dst reg + | BA (ireg) -> failwith "get_builtin_arg: BA_int(not ireg)" + | BA_int _ -> failwith "get_builtin_arg: BA_int" + | BA_long _ -> failwith "get_builtin_arg: BA_long" + | BA_float _ -> failwith "get_builtin_arg: BA_float" + | BA_single _ -> failwith "get_builtin_arg: BA_single" + | BA_loadstack _ -> failwith "get_builtin_arg: BA_loadstack" + | BA_addrstack ofs -> emit (Paddil(dst, stack_pointer, ofs)) + | BA_loadglobal _ -> failwith "get_builtin_arg: BA_loadglobal" + | BA_addrglobal _ -> failwith "get_builtin_arg: BA_addrglobal" + | BA_splitlong _ -> failwith "get_builtin_arg: BA_splitlong" + | BA_addptr _ -> failwith "get_builtin_arg: BA_addptr";; + +(* FIXME DMonniaux this is really suboptimal (byte per byte) *) +let expand_builtin_memcpy_big sz al src dst = + assert (sz > Z.zero); + let dstptr = Asmblock.GPR62 + and srcptr = Asmblock.GPR63 + and tmpbuf = Asmblock.GPR61 in + get_builtin_arg dstptr dst; + get_builtin_arg srcptr src; + emit (Pmake (tmpbuf, sz)); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Plb (tmpbuf, srcptr, Asmblock.Ofsimm Z.zero)); + emit (Paddil (srcptr, srcptr, Z.one)); + emit Psemi; + emit (Psb (tmpbuf, dstptr, Asmblock.Ofsimm Z.zero)); + emit (Paddil (dstptr, dstptr, Z.one)); + emit Psemi; + emit (Plabel lbl);; + let expand_builtin_memcpy sz al args = - let (dst, src) = - match args with [d; s] -> (d, s) | _ -> assert false in - if sz <= 32 - then expand_builtin_memcpy_small sz al src dst - else expand_builtin_memcpy_big sz al src dst + match args with + | [dst; src] -> + expand_builtin_memcpy_big sz al src dst + | _ -> assert false;; (* Handling of volatile reads and writes *) @@ -524,13 +480,12 @@ let expand_instruction instr = | EF_vstore chunk -> expand_builtin_vstore chunk args | EF_annot_val (kind,txt,targ) -> - expand_annot_val kind txt targ args res + expand_annot_val kind txt targ args res *) | EF_memcpy(sz, al) -> - expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args - | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + expand_builtin_memcpy sz al args + (* | EF_annot _ | EF_debug _ | EF_inline_asm _ -> emit instr *) - | EF_memcpy _ -> failwith "asmexpand: memcpy" | EF_malloc -> failwith "asmexpand: malloc" | EF_free -> failwith "asmexpand: free" | EF_vload _ -> failwith "asmexpand: vload" diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 41ea0979..ad932e72 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -168,7 +168,7 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob -(*| EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil *) + | EF_memcpy sz al => R62 :: R63 :: R61 :: nil | _ => nil end. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 0d357962..9b5e31a3 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -244,7 +244,9 @@ module Target (*: TARGET*) = | Pj_l(s) -> fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a?%a\n" bcond bt ireg r print_label lbl + fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl + | Ploopdo (r, lbl) -> + fprintf oc " loopdo %a, %a\n" ireg r print_label lbl (* Load/Store instructions *) | Plb(rd, ra, ofs) -> -- cgit From c3034c18bff34350a7c0d386cd01651622912eb6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Feb 2019 14:58:59 +0100 Subject: Proof of transf_blocks_verified --- mppa_k1c/PostpassSchedulingproof.v | 55 +++++++++++++++++++++++++++++++------- 1 file changed, 46 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index c95a8917..a1d7b977 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -113,6 +113,11 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. +Axiom verified_schedule_size: + forall bb lbb, + verified_schedule bb = OK lbb -> + size bb = size_blocks lbb. + Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). Remark builtin_body_nil: @@ -468,21 +473,53 @@ Proof. Qed. Lemma tail_find_bblock: - forall f ofs bb, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> - exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks f) (bb::c). + forall lbb pos bb, + find_bblock pos lbb = Some bb -> + exists c, code_tail pos lbb (bb::c). Proof. -Admitted. + induction lbb. + - intros. simpl in H. inv H. + - intros. simpl in H. + destruct (zlt pos 0); try (inv H; fail). + 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. + omega. +Qed. + +Lemma code_tail_head_app: + forall l pos c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + size_blocks l) (l++c1) c2. +Proof. + induction l. + - intros. simpl. rewrite Z.add_0_r. auto. + - intros. apply IHl in H. simpl. rewrite (Z.add_comm (size a)). rewrite Z.add_assoc. apply code_tail_S. assumption. +Qed. Lemma transf_blocks_verified: - forall c tc ofs bb c', + forall c tc pos bb c', transf_blocks c = OK tc -> - code_tail (Ptrofs.unsigned ofs) c (bb::c') -> + code_tail pos c (bb::c') -> exists lbb, verified_schedule bb = OK lbb - /\ exists tc', code_tail (Ptrofs.unsigned ofs) tc (lbb ++ tc'). -Proof. -Admitted. + /\ exists tc', code_tail pos tc (lbb ++ tc'). +Proof. + induction c; intros. + - simpl in H. inv H. inv H0. + - inv H0. + + monadInv H. exists (schedule bb). + split; simpl; auto. eexists; eauto. econstructor; eauto. + + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. + exploit IHc; eauto. + intros (lbb & TRANS & tc' & TAIL). + monadInv TRANS. + repeat eexists; eauto. + erewrite verified_schedule_size; eauto. + apply code_tail_head_app. + eauto. +Qed. Lemma transf_find_bblock: forall ofs f bb tf, -- cgit From ae31128c5ca6437d77b29d31fb1441f51a073095 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Feb 2019 17:44:27 +0100 Subject: Encore de la tuyauterie --- mppa_k1c/PostpassSchedulingproof.v | 92 +++++++++++++++++++++++++++++++++++++- 1 file changed, 91 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index a1d7b977..ad423fb0 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -120,6 +120,11 @@ Axiom verified_schedule_size: Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). +Axiom verified_schedule_header: + forall bb tbb lbb, + verified_schedule bb = OK (tbb :: lbb) -> + header bb = header tbb. + Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. @@ -535,12 +540,97 @@ Proof. eapply transf_blocks_verified; eauto. Qed. +Lemma transf_exec_body: + forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. +Proof. +Admitted. + +Lemma symbol_address_preserved: + forall l, Genv.symbol_address ge l Ptrofs.zero = Genv.symbol_address tge l Ptrofs.zero. +Proof. + intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. +Qed. + +Lemma head_tail {A: Type}: + forall (l: list A) hd, hd::l = hd :: (tail (hd::l)). +Proof. + intros. simpl. auto. +Qed. + +Lemma verified_schedule_not_empty: + forall bb lbb, + verified_schedule bb = OK lbb -> lbb <> nil. +Proof. + intros. apply verified_schedule_size in H. + pose (size_positive bb). assert (size_blocks lbb > 0) by omega. clear H g. + destruct lbb; simpl in *; discriminate. +Qed. + +Lemma verified_schedule_label: + forall bb tbb lbb l, + verified_schedule bb = OK (tbb :: lbb) -> + is_label l bb = is_label l tbb. +Proof. +Admitted. + +Lemma label_pos_head_app: + forall c bb lbb l tc, + verified_schedule bb = OK lbb -> + label_pos l 0 c = label_pos l 0 tc -> + label_pos l 0 (bb :: c) = label_pos l 0 (lbb ++ tc). +Proof. + induction c. + - intros. simpl in H0. destruct lbb. + + apply verified_schedule_not_empty in H. contradiction. + + rewrite (head_tail lbb). simpl tl. + simpl. erewrite verified_schedule_label; eauto. + destruct (is_label l b) eqn:ISLBL; simpl; auto. + (* TODO - finish *) +Admitted. + + +Lemma label_pos_preserved: + forall c tc l, + transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. +Proof. + induction c. + - intros. simpl in *. inv H. reflexivity. + - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. eapply IHc in EQ. + eapply label_pos_head_app; eauto. +Qed. + +Lemma label_pos_preserved_blocks: + forall l f tf, + transf_function f = OK tf -> + label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). +Proof. + intros. monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned _); try discriminate. + monadInv EQ0. simpl. eapply label_pos_preserved; eauto. +Qed. + +Lemma transf_exec_control: + forall f tf ex rs m, + transf_function f = OK tf -> + exec_control ge f ex rs m = exec_control tge tf ex rs m. +Proof. + intros. destruct ex; simpl; auto. + assert (ge = Genv.globalenv prog). auto. + assert (tge = Genv.globalenv tprog). auto. + pose symbol_address_preserved. + exploreInst; simpl; auto; try congruence. + - unfold goto_label. erewrite label_pos_preserved_blocks; eauto. +Admitted. + + Lemma transf_exec_bblock: forall f tf bb rs m, transf_function f = OK tf -> exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. Proof. -Admitted. + intros. unfold exec_bblock. rewrite transf_exec_body. destruct (exec_body _ _ _ _); auto. + eapply transf_exec_control; eauto. +Qed. Lemma transf_step_simu: forall tf b lbb ofs c tbb rs m rs' m', -- cgit From 1dffd83e6b621c6ad8d820431339c5dd58e651d1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 1 Feb 2019 21:28:00 +0100 Subject: Ugly hack to get at the k1c standard library stdin/stdout/stderr --- mppa_k1c/TargetPrinter.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 9b5e31a3..93b03907 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -124,12 +124,17 @@ module Target (*: TARGET*) = (* Generate code to load the address of id + ofs in register r *) +(* FIXME DMonniaux ugly ugly hack to get at standard __thread data *) let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); fprintf oc " make %a = %s\n" ireg r (extern_atom id) end else begin - fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) + if (extern_atom id) = "_impure_thread_data" then begin + fprintf oc " make %a = @tprel(%a)\n;;\n addd %a = %a, $r13\n" ireg r symbol_offset (id, ofs) ireg r ireg r + end else begin + fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) + end end (* Emit .file / .loc debugging directives *) -- cgit From db2be07620492d586d3e8993a745b58e39f71d75 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 1 Feb 2019 23:28:19 +0100 Subject: new version of the scheduler, interface to Gurobi in jpeg-6b REOPTIMIZING SUCCEEDED 22 < 23 for 32 instructions REOPTIMIZING SUCCEEDED 81 < 83 for 139 instructions REOPTIMIZING SUCCEEDED 46 < 47 for 81 instructions --- mppa_k1c/InstructionScheduler.ml | 129 +++++++++++++++++++++++++++----------- mppa_k1c/InstructionScheduler.mli | 4 +- 2 files changed, 96 insertions(+), 37 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index b335aab5..4f289780 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -784,41 +784,6 @@ let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solu | Some solution -> reoptimizing_scheduler scheduler solution problem end else previous_solution;; - -let cascaded_scheduler (problem : problem) = - match validated_scheduler list_scheduler problem with - | None -> None - | Some initial_solution -> - let solution = reoptimizing_scheduler (validated_scheduler (pseudo_boolean_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" - end; - Some solution;; - - -(* old - match validated_scheduler list_scheduler problem with - | None -> None - | (Some solution1) as some1 -> - let latency1 = get_max_latency solution1 in - begin - match validated_scheduler pseudo_boolean_scheduler - { problem with max_latency = latency1-1 } with - | None -> - Printf.printf "%d unchanged\n" latency1; - some1 - | (Some solution2) as some2 -> - let latency2 = get_max_latency solution2 in - Printf.printf "%d < %d\n" latency2 latency1; - some2 - end;; - *) let smt_var i = Printf.sprintf "t%d" i @@ -1074,4 +1039,96 @@ let ilp_print_problem channel problem pb_type = done; output_string channel "\n" done; - output_string channel "End\n";; + output_string channel "End\n"; + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = 0; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = [| |]; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +let ilp_read_solution mapper channel = + let times = Array.make + (match mapper.mapper_pb_type with + | OPTIMIZATION -> 1+mapper.mapper_nr_instructions + | SATISFIABILITY -> mapper.mapper_nr_instructions) (-1) in + try + while true do + let line = input_line channel in + ( if (String.length line) < 3 + then failwith (Printf.sprintf "bad ilp output: length(line) < 3: %s" line)); + match String.get line 0 with + | 'x' -> () + | 't' -> let space = + try String.index line ' ' + with Not_found -> + failwith "bad ilp output: no t variable number" + in + let tnumber = + try int_of_string (String.sub line 1 (space-1)) + with Failure _ -> + failwith "bad ilp output: not a variable number" + in + (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 int_of_string (String.sub line (space+1) ((String.length line)-space-1)) + with Failure _ -> + failwith "bad ilp output: not a time number" + in + (if value < 0 + then failwith "bad ilp output: negative time"); + times.(tnumber) <- value + | '#' -> () + | '0' -> () + | _ -> failwith (Printf.sprintf "bad ilp output: bad variable initial, line = %s" line) + done; + assert false + with End_of_file -> + Array.iteri (fun i x -> + if i<(Array.length times)-1 + && x<0 then raise Unschedulable) times; + times;; + +let ilp_solver = ref "ilp_solver" + +let ilp_scheduler pb_type problem = + try + let filename_in = "problem.lp" + and filename_out = "problem.sol" 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 -> + let opb_solution = open_in filename_out in + let ret = adjust_check_solution mapper (ilp_read_solution mapper opb_solution) in + close_in opb_solution; + Some ret + | Unix.WEXITED _ -> failwith "failed to start ilp solver" + | _ -> None + end + with + | Unschedulable -> None;; + +let cascaded_scheduler (problem : problem) = + match validated_scheduler list_scheduler problem with + | None -> None + | Some initial_solution -> + let solution = 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" + end; + Some solution;; + diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli index 1cd286a6..629664f9 100644 --- a/mppa_k1c/InstructionScheduler.mli +++ b/mppa_k1c/InstructionScheduler.mli @@ -102,4 +102,6 @@ val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solutio val smt_print_problem : out_channel -> problem -> unit;; -val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> unit;; +val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; + +val ilp_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; -- cgit From 9e3740fa95cc2a409a21886fdb9e61e2698d7bb6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 2 Feb 2019 23:03:13 +0100 Subject: comment --- mppa_k1c/Machregs.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ad932e72..1c1930da 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -183,6 +183,7 @@ Definition destroyed_at_indirect_call: list mreg := nil. Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). +(* FIXME DMonniaux this seems to be the place for preferred registers for arguments *) Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). (* match ef with | EF_builtin name sg => -- cgit From baeaefa7e1c24e38b3ed41bd894db45057d0eb2b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 Feb 2019 16:20:18 +0100 Subject: Proof of label_pos related things in PostpassSchedulingproof --- mppa_k1c/PostpassSchedulingproof.v | 119 ++++++++++++++++++++++++++++++++----- 1 file changed, 104 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index ad423fb0..08f6f1be 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -123,7 +123,8 @@ Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule Axiom verified_schedule_header: forall bb tbb lbb, verified_schedule bb = OK (tbb :: lbb) -> - header bb = header tbb. + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. @@ -566,28 +567,116 @@ Proof. destruct lbb; simpl in *; discriminate. Qed. +Lemma header_nil_label_pos_none: + forall lbb l p, + Forall (fun b => header b = nil) lbb -> label_pos l p lbb = None. +Proof. + induction lbb. + - intros. simpl. auto. + - intros. inv H. simpl. unfold is_label. rewrite H2. destruct (in_dec l nil). { inv i. } + auto. +Qed. + Lemma verified_schedule_label: forall bb tbb lbb l, verified_schedule bb = OK (tbb :: lbb) -> - is_label l bb = is_label l tbb. + is_label l bb = is_label l tbb + /\ label_pos l 0 lbb = None. Proof. -Admitted. + intros. exploit verified_schedule_header; eauto. + intros (HdrEq & HdrNil). + split. + - unfold is_label. rewrite HdrEq. reflexivity. + - apply header_nil_label_pos_none. assumption. +Qed. -Lemma label_pos_head_app: - forall c bb lbb l tc, - verified_schedule bb = OK lbb -> - label_pos l 0 c = label_pos l 0 tc -> - label_pos l 0 (bb :: c) = label_pos l 0 (lbb ++ tc). +Lemma label_pos_app_none: + forall c c' l p p', + label_pos l p c = None -> + label_pos l (p' + size_blocks c) c' = label_pos l p' (c ++ c'). Proof. induction c. - - intros. simpl in H0. destruct lbb. - + apply verified_schedule_not_empty in H. contradiction. - + rewrite (head_tail lbb). simpl tl. - simpl. erewrite verified_schedule_label; eauto. - destruct (is_label l b) eqn:ISLBL; simpl; auto. - (* TODO - finish *) -Admitted. + - intros. simpl in *. rewrite Z.add_0_r. reflexivity. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLABEL. + + discriminate. + + eapply IHc in H. rewrite Z.add_assoc. eauto. +Qed. + +Remark label_pos_pvar_none_add: + forall tc l p p' k, + label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. +Proof. + induction tc. + - intros. simpl. auto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + discriminate. + + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_none: + forall tc l p p', + label_pos l p tc = None -> label_pos l p' tc = None. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_none_add; eauto. +Qed. + +Remark label_pos_pvar_some_add_add: + forall tc l p p' k k', + label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). +Proof. + induction tc. + - intros. simpl in H. discriminate. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + inv H. assert (k = k') by omega. subst. reflexivity. + + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_some_add: + forall tc l p p' k, + label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_some_add_add; eauto. +Qed. + +Remark label_pos_pvar_add: + forall c tc l p p' k, + label_pos l (p+k) c = label_pos l p tc -> + label_pos l (p'+k) c = label_pos l p' tc. +Proof. + induction c. + - intros. simpl in *. + exploit label_pos_pvar_none; eauto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + exploit label_pos_pvar_some_add; eauto. + + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. +Lemma label_pos_pvar: + forall c tc l p p', + label_pos l p c = label_pos l p tc -> + label_pos l p' c = label_pos l p' tc. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_add; eauto. +Qed. + +Lemma label_pos_head_app: + forall c bb lbb l tc p, + verified_schedule bb = OK lbb -> + label_pos l p c = label_pos l p tc -> + label_pos l p (bb :: c) = label_pos l p (lbb ++ tc). +Proof. + intros. simpl. destruct lbb as [|tbb lbb]. + - apply verified_schedule_not_empty in H. contradiction. + - simpl. exploit verified_schedule_label; eauto. intros (ISLBL & LBLPOS). + rewrite ISLBL. + destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. + eapply label_pos_pvar in H0. erewrite H0. + erewrite verified_schedule_size; eauto. simpl size_blocks. rewrite Z.add_assoc. + erewrite label_pos_app_none; eauto. +Qed. Lemma label_pos_preserved: forall c tc l, -- cgit From 993d6692b722bf366aadbed3b36f7ef51de6cafd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 Feb 2019 16:23:25 +0100 Subject: Proof of transf_exec_control \o/ --- mppa_k1c/PostpassSchedulingproof.v | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 08f6f1be..0ab62578 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -709,8 +709,11 @@ Proof. pose symbol_address_preserved. exploreInst; simpl; auto; try congruence. - unfold goto_label. erewrite label_pos_preserved_blocks; eauto. -Admitted. - + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. +Qed. Lemma transf_exec_bblock: forall f tf bb rs m, -- cgit From e7bf971cf92fd4dd6bd433e1c9842b934bb4752f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 Feb 2019 17:07:59 +0100 Subject: Preuves (en dehors du verified_schedule) terminées dans PostpassSchedulingproof MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 50 +++++++++++++++++++++++++++++++++----- 1 file changed, 44 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 0ab62578..d16362a8 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -106,6 +106,7 @@ Fixpoint concat_all (lbb: list bblock) : res bblock := concat2 bb bb' end. +(* Axioms that verified_schedule must verify *) Axiom verified_schedule_correct: forall ge f bb lbb, verified_schedule bb = OK lbb -> @@ -126,6 +127,10 @@ Axiom verified_schedule_header: header bb = header tbb /\ Forall (fun b => header b = nil) lbb. +(* This needs to be axiomatized since we have no information on low_half (axiomatized parameter, see Asmblock.v) *) +Axiom low_half_preservation: + forall id ofs ge tge, Genv.symbol_address ge id ofs = Genv.symbol_address tge id ofs -> low_half ge id ofs = low_half tge id ofs. + Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. @@ -541,13 +546,8 @@ Proof. eapply transf_blocks_verified; eauto. Qed. -Lemma transf_exec_body: - forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. -Proof. -Admitted. - Lemma symbol_address_preserved: - forall l, Genv.symbol_address ge l Ptrofs.zero = Genv.symbol_address tge l Ptrofs.zero. + forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. Proof. intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. Qed. @@ -715,6 +715,44 @@ Proof. - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. Qed. +Lemma eval_offset_preserved: + forall ofs, eval_offset ge ofs = eval_offset tge ofs. +Proof. + intros. unfold eval_offset. destruct ofs; auto. erewrite low_half_preservation; eauto. + apply symbol_address_preserved. +Qed. + +Lemma transf_exec_load: + forall t rs m rd ra ofs, exec_load ge t rs m rd ra ofs = exec_load tge t rs m rd ra ofs. +Proof. + intros. unfold exec_load. rewrite eval_offset_preserved. reflexivity. +Qed. + +Lemma transf_exec_store: + forall t rs m rs0 ra ofs, exec_store ge t rs m rs0 ra ofs = exec_store tge t rs m rs0 ra ofs. +Proof. + intros. unfold exec_store. rewrite eval_offset_preserved. reflexivity. +Qed. + +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. exploreInst; simpl; auto; try congruence. + 1: unfold exec_arith_instr; exploreInst; simpl; auto; try congruence. + 1-10: apply transf_exec_load. + all: apply transf_exec_store. +Qed. + +Lemma transf_exec_body: + forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. +Proof. + induction bdy; intros. + - simpl. reflexivity. + - simpl. rewrite transf_exec_basic_instr. + destruct (exec_basic_instr _ _ _); auto. +Qed. + Lemma transf_exec_bblock: forall f tf bb rs m, transf_function f = OK tf -> -- cgit From 2ec7281215255202221d0d619f786a2dfde90442 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Feb 2019 11:18:51 +0100 Subject: Fix pour le register allocation --- mppa_k1c/Conventions1.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 7460b2e4..b401c43f 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -47,13 +47,13 @@ Definition int_caller_save_regs := :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. -Definition float_caller_save_regs := R62 :: nil. (* FIXME - for the dummy_float_reg *) +Definition float_caller_save_regs := int_caller_save_regs. Definition int_callee_save_regs := (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. -Definition float_callee_save_regs := @nil mreg. +Definition float_callee_save_regs := int_callee_save_regs. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -- cgit From 2b226da49ea711bfe8139a0fae7c44cb432e2f61 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Feb 2019 13:27:26 +0100 Subject: Removing the low_half axiom --- mppa_k1c/Asmblock.v | 46 +++++++++++++++++--------------------- mppa_k1c/Asmblockgenproof1.v | 34 +++++++++++++++------------- mppa_k1c/PostpassSchedulingproof.v | 11 +++------ mppa_k1c/lib/Asmblockgenproof0.v | 8 +++---- 4 files changed, 46 insertions(+), 53 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 300ab0fc..1600b867 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -934,42 +934,38 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset (** * load/store *) -(** The two functions below axiomatize how the linker processes - symbolic references [symbol + offset)] and splits their - actual values into a 20-bit high part [%hi(symbol + offset)] and - a 12-bit low part [%lo(symbol + offset)]. *) - -Parameter low_half: genv -> ident -> ptrofs -> ptrofs. -Parameter high_half: genv -> ident -> ptrofs -> val. - -(** The fundamental property of these operations is that, when applied - to the address of a symbol, their results can be recombined by - addition, rebuilding the original address. *) - -Axiom low_high_half: - forall id ofs, - Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. - (** Auxiliaries for memory accesses *) -Definition eval_offset (ofs: offset) : ptrofs := +Definition eval_offset (ofs: offset) : res ptrofs := match ofs with - | Ofsimm n => n - | Ofslow id delta => low_half ge id delta + | Ofsimm n => OK n + | Ofslow id delta => + match (Genv.symbol_address ge id delta) with + | Vptr b ofs => OK ofs + | _ => Error (msg "Asmblock.eval_offset") + end end. Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) (d: ireg) (a: ireg) (ofs: offset) := - match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with - | None => Stuck - | Some v => Next (rs#d <- v) m + match (eval_offset ofs) with + | OK ptr => + match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with + | None => Stuck + | Some v => Next (rs#d <- v) m + end + | _ => Stuck end. Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) (s: ireg) (a: ireg) (ofs: offset) := - match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with - | None => Stuck - | Some m' => Next rs m' + match (eval_offset ofs) with + | OK ptr => + match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with + | None => Stuck + | Some m' => Next rs m' + end + | _ => Stuck end. (** * basic instructions *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index bf3be247..81e02e4e 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1268,10 +1268,11 @@ Qed. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, base <> RTMP -> - exists base' ofs' rs', + exists base' ofs' rs' ptr', exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m (mk_instr base' ofs' ::g k) rs' m - /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs + /\ eval_offset ge ofs' = OK ptr' + /\ Val.offset_ptr rs'#base' ptr' = Val.offset_ptr rs#base ofs /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. unfold indexed_memory_access; intros. @@ -1279,7 +1280,7 @@ Proof. assert (Archi.ptr64 = true) as SF; auto. - generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. destruct (make_immed64 (Ptrofs.to_int64 ofs)). -+ econstructor; econstructor; econstructor; split. ++ econstructor; econstructor; econstructor; econstructor; split. apply exec_straight_opt_refl. split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. (* @@ -1326,10 +1327,10 @@ Lemma indexed_load_access_correct: Proof. intros until m; intros EXEC; intros until v; intros LOAD NOT31. exploit indexed_memory_access_correct; eauto. - intros (base' & ofs' & rs' & A & B & C). + intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load. rewrite B, LOAD. eauto. Simpl. + unfold exec_load. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. split; intros; Simpl. auto. Qed. @@ -1346,10 +1347,10 @@ Lemma indexed_store_access_correct: Proof. intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31'. exploit indexed_memory_access_correct. instantiate (1 := base). eauto. - intros (base' & ofs' & rs' & A & B & C). + intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite B, C, STORE. + unfold exec_store. rewrite PtrEq. rewrite B, C, STORE. eauto. discriminate. { intro. inv H. contradiction. } @@ -1463,9 +1464,10 @@ Lemma transl_memory_access_correct: forall mk_instr addr args k c (rs: regset) m v, transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - exists base ofs rs', + exists base ofs rs' ptr, exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m - /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v + /\ eval_offset ge ofs = OK ptr + /\ Val.offset_ptr rs'#base ptr = v /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until v; intros TR EV. @@ -1473,14 +1475,14 @@ Proof. - (* indexed *) inv EV. apply indexed_memory_access_correct; eauto with asmgen. - (* global *) - simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; econstructor; split. constructor. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. unfold eval_offset. + split; split; intros; Simpl. assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). { apply Val.offset_ptr_zero. } remember (Genv.symbol_address ge i i0) as symbol. destruct symbol; auto. - + contradict Heqsymbol; unfold Genv.symbol_address; + + contradict Heqsymbol; unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); discriminate. + contradict Heqsymbol; unfold Genv.symbol_address; destruct (Genv.find_symbol ge i); discriminate. @@ -1507,10 +1509,10 @@ Lemma transl_load_access_correct: Proof. intros until v'; intros INSTR TR EV LOAD. exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & A & B & C). + 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. rewrite B, LOAD. reflexivity. Simpl. + rewrite INSTR. unfold exec_load. rewrite PtrEq, B, LOAD. reflexivity. Simpl. split; intros; Simpl. auto. Qed. @@ -1528,10 +1530,10 @@ Lemma transl_store_access_correct: Proof. intros until m'; intros INSTR TR EV STORE NOT31. exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & A & B & C). + 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_store. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + rewrite INSTR. unfold exec_store. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. intro. inv H. contradiction. auto. Qed. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index d16362a8..c6b037fd 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -127,10 +127,6 @@ Axiom verified_schedule_header: header bb = header tbb /\ Forall (fun b => header b = nil) lbb. -(* This needs to be axiomatized since we have no information on low_half (axiomatized parameter, see Asmblock.v) *) -Axiom low_half_preservation: - forall id ofs ge tge, Genv.symbol_address ge id ofs = Genv.symbol_address tge id ofs -> low_half ge id ofs = low_half tge id ofs. - Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. @@ -242,7 +238,7 @@ Lemma exec_load_pc_var: exec_load ge t rs m rd ra ofs = Next rs' m' -> exec_load ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. + intros. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - discriminate. @@ -253,7 +249,7 @@ Lemma exec_store_pc_var: exec_store ge t rs m rd ra ofs = Next rs' m' -> exec_store ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. + intros. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. - discriminate. @@ -718,8 +714,7 @@ Qed. Lemma eval_offset_preserved: forall ofs, eval_offset ge ofs = eval_offset tge ofs. Proof. - intros. unfold eval_offset. destruct ofs; auto. erewrite low_half_preservation; eauto. - apply symbol_address_preserved. + intros. unfold eval_offset. destruct ofs; auto. erewrite symbol_address_preserved; eauto. Qed. Lemma transf_exec_load: diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 443e8757..8c299f88 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -937,11 +937,11 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + all: try (unfold exec_load in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + all: try (unfold exec_store in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H0. 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. auto. -- cgit From 99d5c85e5595799519e6541947f907a892935e4f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 7 Feb 2019 17:47:00 +0100 Subject: Un peu de refactorisation --- mppa_k1c/PostpassScheduling.v | 87 ++++++++++++++++++++++++++++---------- mppa_k1c/PostpassSchedulingproof.v | 62 +-------------------------- 2 files changed, 67 insertions(+), 82 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index e8e6fcc5..11e53a5d 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -21,10 +21,56 @@ Axiom schedule: bblock -> list bblock. Extract Constant schedule => "PostpassSchedulingOracle.schedule". -(* TODO: refactorisation. - -... concat2 ... - +(* Lemmas necessary for defining concat_all *) +Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. +Proof. + intros. destruct l; simpl. + - contradiction. + - discriminate. +Qed. + +Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. +Proof. + destruct l. + - intros. simpl; auto. + - intros. rewrite <- app_comm_cons. discriminate. +Qed. + +Definition check_size bb := + if zlt Ptrofs.max_unsigned (size bb) + then Error (msg "PostpassSchedulingproof.check_size") + else OK tt. + +Program Definition concat2 (bb bb': bblock) : res bblock := + do ch <- check_size bb; + do ch' <- check_size bb'; + match (exit bb) with + | None => + match (header bb') with + | nil => + match (exit bb') with + | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") + | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. + inversion_clear WF'. inversion_clear WF. clear H1 H3. + inversion H2; inversion H0. + + left. apply app_nonil. auto. + + right. auto. + + left. apply app_nonil2. auto. + + right. auto. + - unfold builtin_alone. intros. rewrite H0 in H. + assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). + apply (H ef args res). contradict H1. auto. +Qed. + Fixpoint concat_all (lbb: list bblock) : res bblock := match lbb with | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") @@ -34,25 +80,22 @@ Fixpoint concat_all (lbb: list bblock) : res bblock := concat2 bb bb' end. -Axiom test_equiv_bblock: bblock -> bblock -> bool. - -Axiom test_equiv_bblock_correct: - forall ge f bb tbb, - test_equiv bb tbb = true -> - bblock_equiv ge f bb tbb. - -Definition verified_schedule (bb : bblock) : res (list bblock) := - DO lbb <- (schedule bb) ; - DO tbb <- (concat lbb) ; - DO res <- test_equiv_bblock bb tbb ; - if res - then OK lbb - else Error (msg "blah"). +Definition verify_schedule (bb bb' : bblock) : res unit := OK tt. -*) - -(* TODO - implement the verificator *) -Definition verified_schedule (bb : bblock) : res (list bblock) := OK (schedule bb). +Program Definition verified_schedule (bb : bblock) : res (list bblock) := + let bb' := {| header := nil; body := body bb; exit := exit bb |} in + let lbb := schedule bb' in + do tbb <- concat_all lbb; + do check <- verify_schedule bb' tbb; + match (head lbb) with + | None => Error (msg "PostpassScheduling.verified_schedule: empty schedule") + | Some fst => OK ({| header := header bb; body := body fst; exit := exit fst |} :: tail lbb) + end. +Next Obligation. + destruct bb; simpl. assumption. +Qed. Next Obligation. + destruct fst; simpl. assumption. +Qed. Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := match lbb with diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index c6b037fd..756e9a9e 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -36,55 +36,6 @@ Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) : exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> bblock_equiv ge f bb bb'. -Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. -Proof. - intros. destruct l; simpl. - - contradiction. - - discriminate. -Qed. - -Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. -Proof. - destruct l. - - intros. simpl; auto. - - intros. rewrite <- app_comm_cons. discriminate. -Qed. - -Definition check_size bb := - if zlt Ptrofs.max_unsigned (size bb) - then Error (msg "PostpassSchedulingproof.check_size") - else OK tt. - -Program Definition concat2 (bb bb': bblock) : res bblock := - do ch <- check_size bb; - do ch' <- check_size bb'; - match (exit bb) with - | None => - match (header bb') with - | nil => - match (exit bb') with - | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") - | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end. -Next Obligation. - apply wf_bblock_refl. constructor. - - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. - inversion_clear WF'. inversion_clear WF. clear H1 H3. - inversion H2; inversion H0. - + left. apply app_nonil. auto. - + right. auto. - + left. apply app_nonil2. auto. - + right. auto. - - unfold builtin_alone. intros. rewrite H0 in H. - assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). - apply (H ef args res). contradict H1. auto. -Qed. - Lemma concat2_zlt_size: forall a b bb, concat2 a b = OK bb -> @@ -97,15 +48,6 @@ Proof. - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. Qed. -Fixpoint concat_all (lbb: list bblock) : res bblock := - match lbb with - | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") - | bb::nil => OK bb - | bb::lbb => - do bb' <- concat_all lbb; - concat2 bb bb' - end. - (* Axioms that verified_schedule must verify *) Axiom verified_schedule_correct: forall ge f bb lbb, @@ -516,12 +458,12 @@ Proof. induction c; intros. - simpl in H. inv H. inv H0. - inv H0. - + monadInv H. exists (schedule bb). + + monadInv H. exists x0. split; simpl; auto. eexists; eauto. econstructor; eauto. + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. exploit IHc; eauto. intros (lbb & TRANS & tc' & TAIL). - monadInv TRANS. +(* monadInv TRANS. *) repeat eexists; eauto. erewrite verified_schedule_size; eauto. apply code_tail_head_app. -- cgit From 292db3a22261821b759abdca011ab93ed01f3cce Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Feb 2019 11:30:51 +0100 Subject: Oshrxlimm --- mppa_k1c/Asmblockgen.v | 8 +++++++- mppa_k1c/Asmblockgenproof1.v | 33 +++++++++++++++++---------------- 2 files changed, 24 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index fa5774ef..4c285c8e 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -543,7 +543,13 @@ Definition transl_op | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n ::i k) - | Oshrxlimm _, _ => Error (msg "Asmblockgen.transl_op: Oshrxlimm") + | Oshrxlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (if Int.eq n Int.zero then Pmv rd rs ::i k else + Psrail RTMP rs (Int.repr 63) ::i + Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i + Paddl RTMP rs RTMP ::i + Psrail rd RTMP n ::i k) (*| Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (if Int.eq n Int.zero then Pmv rd rs :: k else diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 81e02e4e..175eca73 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1164,10 +1164,10 @@ Opaque Int.eq. split; intros; Simpl. + change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. + eapply exec_straight_step. simpl; reflexivity. + eapply exec_straight_step. simpl; reflexivity. + apply exec_straight_one. simpl; reflexivity. split; intros; Simpl. (* - (* Ocast32signed *) exploit cast32signed_correct; eauto. intros (rs' & A & B & C). @@ -1183,6 +1183,19 @@ Opaque Int.eq. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. + contradict n. auto. *) +- (* Oshrxlimm *) + clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros; Simpl. ++ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. + eapply exec_straight_step. simpl; reflexivity. + eapply exec_straight_step. simpl; reflexivity. + apply exec_straight_one. simpl; reflexivity. + + split; intros; Simpl. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. @@ -1248,18 +1261,6 @@ Opaque Int.eq. exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* shrxlimm *) - clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. *) Qed. -- cgit From 66f236124907af065fc8396f8cefd5726a46b06a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Feb 2019 15:39:48 +0100 Subject: Added indirect tailcalls --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 3 +++ mppa_k1c/Asmblockgen.v | 4 ++-- mppa_k1c/Asmblockgenproof.v | 25 ++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++--- mppa_k1c/TargetPrinter.ml | 2 ++ 6 files changed, 38 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d2d562c8..0ce3b455 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -62,6 +62,7 @@ Inductive instruction : Type := | 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 *) @@ -160,6 +161,7 @@ Definition control_to_instruction (c: control) := | PCtlFlow (Asmblock.Pcall l) => Pcall l | PCtlFlow (Asmblock.Picall r) => Picall r | PCtlFlow (Asmblock.Pgoto l) => Pgoto l + | PCtlFlow (Asmblock.Pigoto l) => Pigoto l | PCtlFlow (Asmblock.Pj_l l) => Pj_l l | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l | PCtlFlow (Asmblock.Pcbu bt r l) => Pcbu bt r l diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 1600b867..fcf45bf8 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -224,6 +224,7 @@ Inductive cf_instruction : Type := (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) | Pgoto (l: label) (**r goto *) + | Pigoto (r: ireg) (**r goto from register *) | Pj_l (l: label) (**r jump to label *) (* Conditional branches *) @@ -1149,6 +1150,8 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) Next (rs#RA <- (rs#PC) #PC <- (rs#r)) m | Pgoto s => Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + | Pigoto r => + Next (rs#PC <- (rs#r)) m | Pj_l l => goto_label f l rs m | Pcb bt r l => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 4c285c8e..553d20d4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -845,6 +845,8 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co OK ((Pcall symb) ::g nil) | MBtailcall sig (inr symb) => OK (make_epilogue f ((Pgoto symb) ::g nil)) + | MBtailcall sig (inl r) => + do r1 <- ireg_of r; OK (make_epilogue f ((Pigoto r1) ::g nil)) | MBbuiltin ef args res => OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) | MBgoto lbl => @@ -854,8 +856,6 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co | MBreturn => OK (make_epilogue f (Pret ::g nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) - | MBtailcall _ (inl _) => - Error (msg "Asmblockgen.transl_instr_control MBtailcall inl") | MBjumptable _ _ => Error (msg "Asmblockgen.transl_instr_control MBjumptable") end diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 5a3ab5e1..14a84b6a 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1207,7 +1207,30 @@ Proof. 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. - * inv H1. + * 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. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 5c155540..d15248a2 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -161,6 +161,7 @@ let ctl_flow_rec = function | 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} @@ -333,7 +334,7 @@ type real_instruction = | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd (* BCU *) - | Icall | Call | Cb | Goto | Ret | Get | Set + | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) | Fnegd @@ -379,6 +380,7 @@ let ab_inst_to_real = function | "Pcall" -> Call | "Picall" -> Icall | "Pgoto" | "Pj_l" -> Goto + | "Pigoto" -> Igoto | "Pget" -> Get | "Pret" -> Ret | "Pset" -> Set @@ -430,7 +432,7 @@ let rec_to_usage r = (match encoding with None | Some U6 | Some S10 -> lsu_acc | Some U27L5 | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) - | Icall | Call | Cb | Goto | Ret | Set -> bcu + | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop | Fnegd -> alu_lite @@ -446,7 +448,7 @@ let real_inst_to_latency = function -> 3 (* FIXME - random value *) | Get -> 1 | Set -> 3 - | Icall | Call | Cb | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) + | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) | Fnegd -> 1 let rec_to_info r : inst_info = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 93b03907..d7926c23 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -246,6 +246,8 @@ module Target (*: TARGET*) = fprintf oc " icall %a\n" ireg rs | Pgoto(s) -> fprintf oc " goto %a\n" symbol s + | Pigoto(rs) -> + fprintf oc " igoto %a\n" ireg rs | Pj_l(s) -> fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> -- cgit From 9784c802b7e6c101669bb0db8f8aea881f0a1d5b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Feb 2019 17:56:28 +0100 Subject: Fix for immediate size miscomputation in postpass oracle. --- mppa_k1c/PostpassSchedulingOracle.ml | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index d15248a2..040e9e8d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -198,35 +198,34 @@ type inst_info = { type imm_encoding = U6 | S10 | U27L5 | U27L10 | E27U27L10 let rec pow a = function - | 0 -> 1 - | 1 -> a + | 0 -> Int64.one + | 1 -> Int64.of_int a | n -> let b = pow a (n/2) in - b * b * (if n mod 2 = 0 then 1 else a) + Int64.mul b (Int64.mul b (if n mod 2 = 0 then Int64.one else Int64.of_int a)) -let signed_interval n = begin +let signed_interval n : (int64 * int64) = begin assert (n > 0); - let min = - pow 2 (n-1) - and max = pow 2 (n-1) - 1 + let min = Int64.neg @@ pow 2 (n-1) + and max = Int64.sub (pow 2 (n-1)) Int64.one in (min, max) end let within i interv = match interv with (min, max) -> (i >= min && i <= max) -let signed_length i = - let rec f i n = +let signed_length (i:int64) = + let rec f (i:int64) n = let interv = signed_interval n in if (within i interv) then n else f i (n+1) in f i 1 -let encode_imm imm = - let i = Int64.to_int imm - in let length = signed_length i +let encode_imm (imm:int64) = + let length = signed_length imm in if length <= 7 then U6 (* Unsigned -> 1 bit less needed *) else if length <= 10 then S10 else if length <= 32 then U27L5 (* Upper 27 Lower 5 is signed *) else if length <= 37 then U27L10 else if length <= 64 then E27U27L10 - else failwith @@ sprintf "encode_imm: integer too big! (%d)" i + 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"] -- cgit From b66c1d482292c15e3d7907262cf1c94edabdd40e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 11 Feb 2019 16:11:22 +0100 Subject: Proving verified_schedule_size axiom --- mppa_k1c/PostpassScheduling.v | 69 ++++++++++++++++++++++++++++++++------ mppa_k1c/PostpassSchedulingproof.v | 5 --- 2 files changed, 58 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 11e53a5d..5fec35fb 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -82,19 +82,66 @@ Fixpoint concat_all (lbb: list bblock) : res bblock := Definition verify_schedule (bb bb' : bblock) : res unit := OK tt. -Program Definition verified_schedule (bb : bblock) : res (list bblock) := - let bb' := {| header := nil; body := body bb; exit := exit bb |} in - let lbb := schedule bb' in - do tbb <- concat_all lbb; - do check <- verify_schedule bb' tbb; - match (head lbb) with - | None => Error (msg "PostpassScheduling.verified_schedule: empty schedule") - | Some fst => OK ({| header := header bb; body := body fst; exit := exit fst |} :: tail lbb) - end. +Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). + +Lemma verify_size_size: + forall bb lbb, verify_size bb lbb = OK tt -> size bb = size_blocks lbb. +Proof. + intros. unfold verify_size in H. destruct (size bb =? size_blocks lbb) eqn:SIZE; try discriminate. + apply Z.eqb_eq. assumption. +Qed. + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. -Qed. Next Obligation. - destruct fst; simpl. assumption. +Qed. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Qed. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Definition stick_header_code (h : list label) (lbb : list bblock) := + match (head lbb) with + | None => Error (msg "PostpassScheduling.stick_header: empty schedule") + | Some fst => OK ((stick_header h fst) :: tail lbb) + end. + +Lemma hd_tl_size: + forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). +Proof. + destruct lbb. + - intros. simpl in H. discriminate. + - intros. simpl in H. inv H. simpl. reflexivity. +Qed. + +Lemma stick_header_code_size: + forall h lbb lbb', stick_header_code h lbb = OK lbb' -> size_blocks lbb = size_blocks lbb'. +Proof. + intros. unfold stick_header_code in H. destruct (hd_error lbb) eqn:HD; try discriminate. + inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. +Qed. + +Definition verified_schedule (bb : bblock) : res (list bblock) := + let bb' := no_header bb in + let lbb := schedule bb' in + do tbb <- concat_all lbb; + do sizecheck <- verify_size bb lbb; + do schedcheck <- verify_schedule bb' tbb; + stick_header_code (header bb) lbb. + +Lemma verified_schedule_size: + forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. +Proof. + intros. monadInv H. erewrite <- stick_header_code_size; eauto. + apply verify_size_size. + destruct x0; try discriminate. assumption. Qed. Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 756e9a9e..64489e16 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -56,11 +56,6 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. -Axiom verified_schedule_size: - forall bb lbb, - verified_schedule bb = OK lbb -> - size bb = size_blocks lbb. - Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). Axiom verified_schedule_header: -- cgit From 20745c6ce58093bca0b1c8d696444ed9be5f47a9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 10:50:14 +0100 Subject: Proving the axiom verified_schedule_single_inst --- mppa_k1c/PostpassScheduling.v | 38 +++++++++++++++++++++++++++++++++++--- mppa_k1c/PostpassSchedulingproof.v | 2 -- 2 files changed, 35 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 5fec35fb..401228dc 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -11,7 +11,7 @@ (* *********************************************************************) Require Import Coqlib Errors AST Integers. -Require Import Asmblock. +Require Import Asmblock Axioms. Local Open Scope error_monad_scope. @@ -94,12 +94,18 @@ Qed. Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. Qed. Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. -Qed. +Defined. Lemma stick_header_size: forall h bb, size (stick_header h bb) = size bb. @@ -107,12 +113,25 @@ Proof. intros. destruct bb. unfold stick_header. simpl. reflexivity. Qed. +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. +Qed. + Definition stick_header_code (h : list label) (lbb : list bblock) := match (head lbb) with | None => Error (msg "PostpassScheduling.stick_header: empty schedule") | Some fst => OK ((stick_header h fst) :: tail lbb) end. +Lemma stick_header_code_no_header: + forall bb c, + stick_header_code (header bb) (no_header bb :: c) = OK (bb :: c). +Proof. + intros. unfold stick_header_code. simpl. rewrite stick_header_no_header. reflexivity. +Qed. + Lemma hd_tl_size: forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). Proof. @@ -128,9 +147,12 @@ Proof. inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. Qed. +Definition do_schedule (bb: bblock) : list bblock := + if (Z.eqb (size bb) 1) then bb::nil else schedule bb. + Definition verified_schedule (bb : bblock) : res (list bblock) := let bb' := no_header bb in - let lbb := schedule bb' in + let lbb := do_schedule bb' in do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; @@ -144,6 +166,16 @@ Proof. destruct x0; try discriminate. assumption. Qed. +Lemma verified_schedule_single_inst: + forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). +Proof. + intros. unfold verified_schedule. + unfold do_schedule. rewrite no_header_size. rewrite H. simpl. + unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). simpl. + apply stick_header_code_no_header. + rewrite H. reflexivity. +Qed. + Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := match lbb with | nil => OK nil diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 64489e16..16965af4 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -56,8 +56,6 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. -Axiom verified_schedule_single_inst: forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). - Axiom verified_schedule_header: forall bb tbb lbb, verified_schedule bb = OK (tbb :: lbb) -> -- cgit From ede096d051de168bd52b41e1d909e0b017899094 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 11:51:38 +0100 Subject: Proof of axiom verified_schedule_header --- mppa_k1c/PostpassScheduling.v | 133 +++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassSchedulingproof.v | 59 ---------------- 2 files changed, 133 insertions(+), 59 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 401228dc..ef455e39 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -71,6 +71,70 @@ Next Obligation. apply (H ef args res). contradict H1. auto. Qed. +Lemma concat2_noexit: + forall a b bb, + concat2 a b = OK bb -> + exit a = None. +Proof. + intros. destruct a as [hd bdy ex WF]; simpl in *. + destruct ex as [e|]; simpl in *; auto. + unfold concat2 in H. simpl in H. monadInv H. +Qed. + +Lemma concat2_decomp: + forall a b bb, + concat2 a b = OK bb -> + body bb = body a ++ body b + /\ exit bb = exit b. +Proof. + intros. exploit concat2_noexit; eauto. intros. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. + subst exa. + unfold concat2 in H; simpl in H. + destruct hdb. + - destruct exb. + + destruct c. + * destruct i. monadInv H. + * monadInv H. split; auto. + + monadInv H. split; auto. + - monadInv H. +Qed. + +Lemma concat2_size: + forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. +Proof. + intros. unfold concat2 in H. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. + destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). + - destruct c. + + destruct i; try (monadInv EQ2). + + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. + - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. +Qed. + +Lemma concat2_header: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> header bb = header tbb. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. + - destruct c. + + destruct i; discriminate. + + congruence. + - congruence. +Qed. + +Lemma concat2_no_header_in_middle: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> + header bb' = nil. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. +Qed. + Fixpoint concat_all (lbb: list bblock) : res bblock := match lbb with | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") @@ -80,6 +144,42 @@ Fixpoint concat_all (lbb: list bblock) : res bblock := concat2 bb bb' end. +Lemma concat_all_size : + forall lbb a bb bb', + concat_all (a :: lbb) = OK bb -> + concat_all lbb = OK bb' -> + size bb = size a + size bb'. +Proof. + intros. unfold concat_all in H. fold concat_all in H. + destruct lbb; try discriminate. + monadInv H. rewrite H0 in EQ. inv EQ. + apply concat2_size. assumption. +Qed. + +Lemma concat_all_header: + forall lbb bb tbb, + concat_all (bb::lbb) = OK tbb -> header bb = header tbb. +Proof. + destruct lbb. + - intros. simpl in H. congruence. + - intros. simpl in H. destruct lbb. + + inv H. eapply concat2_header; eassumption. + + monadInv H. eapply concat2_header; eassumption. +Qed. + +Lemma concat_all_no_header_in_middle: + forall lbb tbb, + concat_all lbb = OK tbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + induction lbb; intros; try constructor. + simpl. simpl in H. destruct lbb. + - constructor. + - monadInv H. simpl tl in IHlbb. constructor. + + apply concat2_no_header_in_middle in EQ0. apply concat_all_header in EQ. congruence. + + apply IHlbb in EQ. assumption. +Qed. + Definition verify_schedule (bb bb' : bblock) : res unit := OK tt. Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). @@ -147,6 +247,18 @@ Proof. inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. Qed. +Lemma stick_header_code_no_header_in_middle: + forall c h lbb, + stick_header_code h c = OK lbb -> + Forall (fun b => header b = nil) (tl c) -> + Forall (fun b => header b = nil) (tl lbb). +Proof. + destruct c; intros. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. simpl in H0. + simpl. assumption. +Qed. + Definition do_schedule (bb: bblock) : list bblock := if (Z.eqb (size bb) 1) then bb::nil else schedule bb. @@ -176,6 +288,27 @@ Proof. rewrite H. reflexivity. Qed. +Lemma verified_schedule_no_header_in_middle: + forall lbb bb, + verified_schedule bb = OK lbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. + eapply concat_all_no_header_in_middle. eassumption. +Qed. + +Lemma verified_schedule_header: + forall bb tbb lbb, + verified_schedule bb = OK (tbb :: lbb) -> + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. +Proof. + intros. split. + - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. + simpl. reflexivity. + - apply verified_schedule_no_header_in_middle in H. assumption. +Qed. + Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := match lbb with | nil => OK nil diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 16965af4..19d30354 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -56,12 +56,6 @@ Axiom verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. -Axiom verified_schedule_header: - forall bb tbb lbb, - verified_schedule bb = OK (tbb :: lbb) -> - header bb = header tbb - /\ Forall (fun b => header b = nil) lbb. - Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. @@ -82,35 +76,6 @@ Proof. - unfold size. rewrite H. rewrite H1. simpl. auto. Qed. -Lemma concat2_noexit: - forall a b bb, - concat2 a b = OK bb -> - exit a = None. -Proof. - intros. destruct a as [hd bdy ex WF]; simpl in *. - destruct ex as [e|]; simpl in *; auto. - unfold concat2 in H. simpl in H. monadInv H. -Qed. - -Lemma concat2_decomp: - forall a b bb, - concat2 a b = OK bb -> - body bb = body a ++ body b - /\ exit bb = exit b. -Proof. - intros. exploit concat2_noexit; eauto. intros. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. - subst exa. - unfold concat2 in H; simpl in H. - destruct hdb. - - destruct exb. - + destruct c. - * destruct i. monadInv H. - * monadInv H. split; auto. - + monadInv H. split; auto. - - monadInv H. -Qed. - Lemma exec_body_app: forall l l' ge rs m rs'' m'', exec_body ge (l ++ l') rs m = Next rs'' m'' -> @@ -299,30 +264,6 @@ Proof. exists x. repeat econstructor. all: eauto. Qed. -Lemma concat2_size: - forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. -Proof. - intros. unfold concat2 in H. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. - destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). - - destruct c. - + destruct i; try (monadInv EQ2). - + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. - - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. -Qed. - -Lemma concat_all_size : - forall lbb a bb bb', - concat_all (a :: lbb) = OK bb -> - concat_all lbb = OK bb' -> - size bb = size a + size bb'. -Proof. - intros. unfold concat_all in H. fold concat_all in H. - destruct lbb; try discriminate. - monadInv H. rewrite H0 in EQ. inv EQ. - apply concat2_size. assumption. -Qed. - Lemma ptrofs_add_repr : forall a b, Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). -- cgit From 1f38df638dfd4ae2aa85467cc28f6b4fa1da03b1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 11:57:16 +0100 Subject: Minor refactorization --- mppa_k1c/PostpassScheduling.v | 12 ++++++++++++ mppa_k1c/PostpassSchedulingproof.v | 12 ------------ 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index ef455e39..10331f15 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -71,6 +71,18 @@ Next Obligation. apply (H ef args res). contradict H1. auto. Qed. +Lemma concat2_zlt_size: + forall a b bb, + concat2 a b = OK bb -> + size a <= Ptrofs.max_unsigned + /\ size b <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. + split. + - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. + - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. +Qed. + Lemma concat2_noexit: forall a b bb, concat2 a b = OK bb -> diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 19d30354..d0aa89a4 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -36,18 +36,6 @@ Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) : exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> bblock_equiv ge f bb bb'. -Lemma concat2_zlt_size: - forall a b bb, - concat2 a b = OK bb -> - size a <= Ptrofs.max_unsigned - /\ size b <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. - split. - - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. - - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. -Qed. - (* Axioms that verified_schedule must verify *) Axiom verified_schedule_correct: forall ge f bb lbb, -- cgit From 40bc8bf185c5cd3c5620cf4fe24ebcc9511c79fb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 15:10:20 +0100 Subject: Added Ofloatconst and Osingleconst (not integrated in scheduler yet) --- mppa_k1c/Asm.v | 12 ++++++++++++ mppa_k1c/Asmblock.v | 23 +++++++++++++++++++++++ mppa_k1c/Asmblockgen.v | 14 ++++---------- mppa_k1c/PostpassSchedulingOracle.ml | 2 ++ mppa_k1c/TargetPrinter.ml | 12 ++++++++++++ 5 files changed, 53 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 0ce3b455..b22ea100 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -105,6 +105,12 @@ Inductive instruction : Type := (** 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 *) @@ -195,6 +201,12 @@ Definition basic_to_instruction (b: basic) := (* RI64 *) | PArithRI64 Asmblock.Pmakel rd imm => Pmakel rd imm + (* RF32 *) + | PArithRF32 Asmblock.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmblock.Pmakef rd imm => Pmakef rd imm + (* RRR *) | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fcf45bf8..aa59d645 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -293,6 +293,14 @@ Inductive arith_name_ri64 : Type := | Pmakel (**r load immediate long *) . +Inductive arith_name_rf32 : Type := + | Pmakefs (**r load immediate single *) +. + +Inductive arith_name_rf64 : Type := + | Pmakef (**r load immediate float *) +. + Inductive arith_name_rrr : Type := | Pcompw (it: itest) (**r comparison word *) | Pcompl (it: itest) (**r comparison long *) @@ -347,6 +355,8 @@ Inductive ar_instruction : Type := | PArithRR (i: arith_name_rr) (rd rs: ireg) | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRF32 (i: arith_name_rf32) (rd: ireg) (imm: float32) + | PArithRF64 (i: arith_name_rf64) (rd: ireg) (imm: float) | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) @@ -356,6 +366,8 @@ Coercion PArithR: arith_name_r >-> Funclass. Coercion PArithRR: arith_name_rr >-> Funclass. Coercion PArithRI32: arith_name_ri32 >-> Funclass. Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRF32: arith_name_rf32 >-> Funclass. +Coercion PArithRF64: arith_name_rf64 >-> Funclass. Coercion PArithRRR: arith_name_rrr >-> Funclass. Coercion PArithRRI32: arith_name_rri32 >-> Funclass. Coercion PArithRRI64: arith_name_rri64 >-> Funclass. @@ -844,6 +856,7 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := | None => Vundef end . + (** Execution of arith instructions TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... @@ -883,6 +896,16 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pmakel => rs#d <- (Vlong i) end + | PArithRF32 n d i => + match n with + | Pmakefs => rs#d <- (Vsingle i) + end + + | PArithRF64 n d i => + match n with + | Pmakef => rs#d <- (Vfloat i) + end + | PArithRRR n d s1 s2 => match n with | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 553d20d4..b82ada55 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -350,19 +350,13 @@ Definition transl_op | Olongconst n, nil => do rd <- ireg_of res; OK (loadimm64 rd n ::i k) - | Ofloatconst _, _ => Error(msg "Asmblockgen.transl_op: Ofloatconst") - | Osingleconst _, _ => Error(msg "Asmblockgen.transl_op: Osingleconst") -(*| Ofloatconst f, nil => + | Ofloatconst f, nil => do rd <- freg_of res; - OK (if Float.eq_dec f Float.zero - then Pfcvtdw rd GPR0 :: k - else Ploadfi rd f :: k) + OK (Pmakef rd f ::i k) | Osingleconst f, nil => do rd <- freg_of res; - OK (if Float32.eq_dec f Float32.zero - then Pfcvtsw rd GPR0 :: k - else Ploadsi rd f :: k) -*)| Oaddrsymbol s ofs, nil => + OK (Pmakefs rd f ::i k) + | Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 040e9e8d..614af7f5 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -127,6 +127,8 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_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) -> raise OpaqueInstruction (* FIXME - complete later *) + | PArithRF64 (rd, f) -> raise OpaqueInstruction | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) | PArithR (i, rd) -> arith_r_rec i (IR rd) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d7926c23..aa6c167d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -303,6 +303,18 @@ module Target (*: TARGET*) = | Pmakel (rd, imm) -> fprintf oc " make %a, %a\n" ireg rd coqint64 imm + (* Arith RF32 instructions *) + | Pmakefs (rd, f) -> + let d = Floats.Float32.to_bits f in + fprintf oc " make %a, %a %s %.18g\n" + ireg rd coqint d comment (camlfloat_of_coqfloat32 f) + + (* Arith RF64 instructions *) + | Pmakef (rd, f) -> + let d = Floats.Float.to_bits f in + fprintf oc " make %a, %a %s %.18g\n" + ireg rd coqint64 d comment (camlfloat_of_coqfloat f) + (* Arith RRR instructions *) | Pcompw (it, rd, rs1, rs2) -> fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 -- cgit From 0a56ab26bc776468e6cf462cb5136fd62d4eb44a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 15:15:51 +0100 Subject: Added Pmakefs and Pmakef to the scheduler --- mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 614af7f5..b5f74a6d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -81,6 +81,10 @@ 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" @@ -127,8 +131,10 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_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) -> raise OpaqueInstruction (* FIXME - complete later *) - | PArithRF64 (rd, f) -> raise OpaqueInstruction + | 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} | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) | PArithR (i, rd) -> arith_r_rec i (IR rd) @@ -360,7 +366,7 @@ let ab_inst_to_real = function | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pxorl" | "Pxoril" -> Xord - | "Pmake" | "Pmakel" | "Ploadsymbol" -> Make + | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd | "Pzxwd" -> Zxwd -- cgit From 41109bd86942b028240ac20758ff29853b025534 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 16:24:56 +0100 Subject: Added Osingleofint --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 2 ++ mppa_k1c/Asmblockgen.v | 25 ++++++++++++------------- mppa_k1c/PostpassSchedulingOracle.ml | 6 +++++- mppa_k1c/PostpassSchedulingproof.v | 7 +++++-- mppa_k1c/TargetPrinter.ml | 2 ++ 6 files changed, 28 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b22ea100..cf7d1ef1 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -98,6 +98,7 @@ Inductive instruction : Type := | 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 *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer *) (** Arith RI32 *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) @@ -194,6 +195,7 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Psxwd rd rs => Psxwd rd rs | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs (* RI32 *) | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index aa59d645..fbc9a5c6 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -283,6 +283,7 @@ Inductive arith_name_rr : Type := | Pcvtl2w (**r Convert Long to Word *) | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) + | Pfloatwrnsz (**r Floating Point Conversion from integer *) . Inductive arith_name_ri32 : Type := @@ -884,6 +885,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pcvtl2w => rs#d <- (Val.loword rs#s) | Psxwd => rs#d <- (Val.longofint rs#s) | Pzxwd => rs#d <- (Val.longofintu rs#s) + | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) end | PArithRI32 n d i => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index b82ada55..07051111 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -544,17 +544,12 @@ Definition transl_op Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i Paddl RTMP rs RTMP ::i Psrail rd RTMP n ::i k) -(*| Oshrxlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs :: k else - Psrail GPR31 rs (Int.repr 63) :: - Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: - Paddl GPR31 rs GPR31 :: - Psrail rd GPR31 n :: k) - -*)| Onegf, a1 :: nil => + | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs ::i k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfloatwrnsz rd rs ::i k) | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") @@ -566,6 +561,10 @@ Definition transl_op | Osubfs , _ => Error (msg "Asmblockgen.transl_op: Osubfs") | Omulfs , _ => Error (msg "Asmblockgen.transl_op: Omulfs") | Odivfs , _ => Error (msg "Asmblockgen.transl_op: Odivfs") + | Ofloatoflong , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflong") + | Ofloatoflongu , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflongu") + | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") + | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") | Osingleoffloat , _ => Error (msg "Asmblockgen.transl_op: Osingleoffloat") | Ofloatofsingle , _ => Error (msg "Asmblockgen.transl_op: Ofloatofsingle") | Ointoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointoffloat") @@ -578,12 +577,12 @@ Definition transl_op | Osingleofintu , _ => Error (msg "Asmblockgen.transl_op: Osingleofintu") | Olongoffloat , _ => Error (msg "Asmblockgen.transl_op: Olongoffloat") | Olonguoffloat , _ => Error (msg "Asmblockgen.transl_op: Olonguoffloat") - | Ofloatoflong , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflong") - | Ofloatoflongu , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflongu") + + | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") - | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") - | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") + + (*| Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs :: k) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b5f74a6d..2338da91 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -34,6 +34,7 @@ let arith_rr_str = function | Pfnegd -> "Pfnegd" | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" + | Pfloatwrnsz -> "Pfloatwrnsz" let arith_rrr_str = function | Pcompw it -> "Pcompw" @@ -343,7 +344,7 @@ type real_instruction = (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) - | Fnegd + | Fnegd | Floatwz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -370,6 +371,7 @@ let ab_inst_to_real = function | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd | "Pzxwd" -> Zxwd + | "Pfloatwrnsz" -> Floatwz | "Plb" -> Lbs | "Plbu" -> Lbz @@ -431,6 +433,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) + | Floatwz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -449,6 +452,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 + | Floatwz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index d0aa89a4..ceea8de5 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -149,9 +149,12 @@ Lemma exec_basic_instr_pc_var: exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. Proof. intros. unfold exec_basic_instr in *. destruct i. - - unfold exec_arith_instr in *. exploreInst. - all: try (inv H; apply next_eq; auto; + - 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 *) + inv H. apply next_eq; auto. apply functional_extensionality; intros. rewrite regset_double_set; auto. discriminate. - exploreInst; apply exec_load_pc_var; auto. - exploreInst; apply exec_store_pc_var; auto. - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index aa6c167d..9a96cf3b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -294,6 +294,8 @@ module Target (*: TARGET*) = fprintf oc " sxwd %a = %a\n" ireg rd ireg rs | Pzxwd(rd, rs) -> fprintf oc " zxwd %a = %a\n" ireg rd ireg rs + | Pfloatwrnsz(rd, rs) -> + fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs (* Arith RI32 instructions *) | Pmake (rd, imm) -> -- cgit From 685c2f76b5f8b320495868cfdcadbf203f50a0bd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 16:47:18 +0100 Subject: Added Ointofsingle + floatconv unit test --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 4 +++- mppa_k1c/Asmblockgen.v | 5 ++++- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++--- mppa_k1c/PostpassSchedulingproof.v | 2 +- mppa_k1c/TargetPrinter.ml | 2 ++ 6 files changed, 17 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index cf7d1ef1..35e3710c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -99,6 +99,7 @@ Inductive instruction : Type := | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) (** Arith RI32 *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) @@ -196,6 +197,7 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs (* RI32 *) | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fbc9a5c6..643870ea 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -283,7 +283,8 @@ Inductive arith_name_rr : Type := | Pcvtl2w (**r Convert Long to Word *) | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) - | Pfloatwrnsz (**r Floating Point Conversion from integer *) + | Pfloatwrnsz (**r Floating Point Conversion from integer (single -> int) *) + | Pfixedwrzz (**r Integer conversion from floating point (int -> single) *) . Inductive arith_name_ri32 : Type := @@ -886,6 +887,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Psxwd => rs#d <- (Val.longofint rs#s) | Pzxwd => rs#d <- (Val.longofintu rs#s) | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) + | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) end | PArithRI32 n d i => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 07051111..80790465 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -548,8 +548,11 @@ Definition transl_op do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs ::i k) | Osingleofint, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; + do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatwrnsz rd rs ::i k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedwrzz rd rs ::i k) | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2338da91..a09d696f 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -35,6 +35,7 @@ let arith_rr_str = function | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" | Pfloatwrnsz -> "Pfloatwrnsz" + | Pfixedwrzz -> "Pfixedwrzz" let arith_rrr_str = function | Pcompw it -> "Pcompw" @@ -344,7 +345,7 @@ type real_instruction = (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) - | Fnegd | Floatwz + | Fnegd | Floatwz | Fixedwz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -372,6 +373,7 @@ let ab_inst_to_real = function | "Psxwd" -> Sxwd | "Pzxwd" -> Zxwd | "Pfloatwrnsz" -> Floatwz + | "Pfixedwrzz" -> Fixedwz | "Plb" -> Lbs | "Plbu" -> Lbz @@ -433,7 +435,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Floatwz -> mau + | Fixedwz | Floatwz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -452,7 +454,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 - | Floatwz -> 4 + | Floatwz | Fixedwz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index ceea8de5..492687cd 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -154,7 +154,7 @@ Proof. apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). (* Some cases treated seperately because exploreInst destructs too much *) - inv H. apply next_eq; auto. apply functional_extensionality; intros. rewrite regset_double_set; auto. discriminate. + all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). - exploreInst; apply exec_load_pc_var; auto. - exploreInst; apply exec_store_pc_var; auto. - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 9a96cf3b..1a73ae7a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -296,6 +296,8 @@ module Target (*: TARGET*) = fprintf oc " zxwd %a = %a\n" ireg rd ireg rs | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfixedwrzz(rd, rs) -> + fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs (* Arith RI32 instructions *) | Pmake (rd, imm) -> -- cgit From adfc93550f1e4948ed4f39d52a4f6eece9c8a35d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Feb 2019 17:05:04 +0100 Subject: Added Olongoffloat, Ofloatoflong and doubleconv test --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmblock.v | 4 ++++ mppa_k1c/Asmblockgen.v | 6 ++++++ mppa_k1c/PostpassSchedulingOracle.ml | 10 +++++++--- mppa_k1c/TargetPrinter.ml | 4 ++++ 5 files changed, 25 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 35e3710c..d7bfaffe 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -99,7 +99,9 @@ Inductive instruction : Type := | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (64 bits) *) (** Arith RI32 *) | Pmake (rd: ireg) (imm: int) (**r load immediate *) @@ -197,7 +199,9 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmblock.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmblock.Pfixeddrzz rd rs => Pfixeddrzz rd rs (* RI32 *) | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 643870ea..3cd300c9 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -284,7 +284,9 @@ Inductive arith_name_rr : Type := | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) | Pfloatwrnsz (**r Floating Point Conversion from integer (single -> int) *) + | Pfloatdrnsz (**r Floating Point Conversion from integer (float -> long) *) | Pfixedwrzz (**r Integer conversion from floating point (int -> single) *) + | Pfixeddrzz (**r Integer conversion from floating point (long -> float) *) . Inductive arith_name_ri32 : Type := @@ -887,7 +889,9 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Psxwd => rs#d <- (Val.longofint rs#s) | Pzxwd => rs#d <- (Val.longofintu rs#s) | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) + | Pfloatdrnsz => rs#d <- (match Val.floatoflong rs#s with Some f => f | _ => Vundef end) | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) + | Pfixeddrzz => rs#d <- (match Val.longoffloat rs#s with Some i => i | _ => Vundef end) end | PArithRI32 n d i => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 80790465..e7fa8f6c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -550,9 +550,15 @@ Definition transl_op | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatwrnsz rd rs ::i k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatdrnsz rd rs ::i k) | Ointofsingle, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedwrzz rd rs ::i k) + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeddrzz rd rs ::i k) | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a09d696f..ddc31ebc 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -35,7 +35,9 @@ let arith_rr_str = function | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" | Pfloatwrnsz -> "Pfloatwrnsz" + | Pfloatdrnsz -> "Pfloatdrnsz" | Pfixedwrzz -> "Pfixedwrzz" + | Pfixeddrzz -> "Pfixeddrzz" let arith_rrr_str = function | Pcompw it -> "Pcompw" @@ -345,7 +347,7 @@ type real_instruction = (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) - | Fnegd | Floatwz | Fixedwz + | Fnegd | Floatwz | Floatdz | Fixedwz | Fixeddz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -373,7 +375,9 @@ let ab_inst_to_real = function | "Psxwd" -> Sxwd | "Pzxwd" -> Zxwd | "Pfloatwrnsz" -> Floatwz + | "Pfloatdrnsz" -> Floatdz | "Pfixedwrzz" -> Fixedwz + | "Pfixeddrzz" -> Fixeddz | "Plb" -> Lbs | "Plbu" -> Lbz @@ -435,7 +439,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Fixedwz | Floatwz -> mau + | Fixedwz | Floatwz | Fixeddz | Floatdz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -454,7 +458,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 - | Floatwz | Fixedwz -> 4 + | Floatwz | Fixedwz | Floatdz | Fixeddz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 1a73ae7a..703863b7 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -296,8 +296,12 @@ module Target (*: TARGET*) = fprintf oc " zxwd %a = %a\n" ireg rd ireg rs | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatdrnsz(rd, rs) -> + fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfixedwrzz(rd, rs) -> fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixeddrzz(rd, rs) -> + fprintf oc " fixedd.rz %a = %a, 0\n" ireg rd ireg rs (* Arith RI32 instructions *) | Pmake (rd, imm) -> -- cgit From 706937c529543fed0c522fe28c1f32ec08ddea09 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Feb 2019 11:04:30 +0100 Subject: Added AbstractBasicBlock files to the Coq build process --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 214 ++++++ mppa_k1c/abstractbb/DepExample.v | 151 ++++ mppa_k1c/abstractbb/DepExampleDemo.v | 396 ++++++++++ mppa_k1c/abstractbb/DepExampleEqTest.v | 326 ++++++++ mppa_k1c/abstractbb/DepExampleParallelTest.v | 161 ++++ mppa_k1c/abstractbb/DepTreeTheory.v | 411 ++++++++++ mppa_k1c/abstractbb/ImpDep.v | 847 +++++++++++++++++++++ mppa_k1c/abstractbb/Impure/ImpConfig.v | 82 ++ mppa_k1c/abstractbb/Impure/ImpCore.v | 187 +++++ mppa_k1c/abstractbb/Impure/ImpExtern.v | 7 + mppa_k1c/abstractbb/Impure/ImpHCons.v | 48 ++ mppa_k1c/abstractbb/Impure/ImpIO.v | 159 ++++ mppa_k1c/abstractbb/Impure/ImpLoops.v | 121 +++ mppa_k1c/abstractbb/Impure/ImpMonads.v | 148 ++++ mppa_k1c/abstractbb/Impure/ImpPrelude.v | 163 ++++ mppa_k1c/abstractbb/Impure/LICENSE | 165 ++++ mppa_k1c/abstractbb/Impure/README.md | 31 + .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 51 ++ .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 3 + mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 146 ++++ mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli | 34 + mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml | 78 ++ .../abstractbb/Impure/ocaml/ImpLoopOracles.mli | 8 + mppa_k1c/abstractbb/Parallelizability.v | 743 ++++++++++++++++++ mppa_k1c/abstractbb/README.md | 12 + 25 files changed, 4692 insertions(+) create mode 100644 mppa_k1c/abstractbb/AbstractBasicBlocksDef.v create mode 100644 mppa_k1c/abstractbb/DepExample.v create mode 100644 mppa_k1c/abstractbb/DepExampleDemo.v create mode 100644 mppa_k1c/abstractbb/DepExampleEqTest.v create mode 100644 mppa_k1c/abstractbb/DepExampleParallelTest.v create mode 100644 mppa_k1c/abstractbb/DepTreeTheory.v create mode 100644 mppa_k1c/abstractbb/ImpDep.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpConfig.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpCore.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpExtern.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpHCons.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpIO.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpLoops.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpMonads.v create mode 100644 mppa_k1c/abstractbb/Impure/ImpPrelude.v create mode 100644 mppa_k1c/abstractbb/Impure/LICENSE create mode 100644 mppa_k1c/abstractbb/Impure/README.md create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml create mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli create mode 100644 mppa_k1c/abstractbb/Parallelizability.v create mode 100644 mppa_k1c/abstractbb/README.md (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v new file mode 100644 index 00000000..50ce000e --- /dev/null +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -0,0 +1,214 @@ +(** Syntax and Sequential Semantics of Abstract Basic Blocks. +*) + + +Module Type ResourceNames. + +Parameter t: Type. + +Parameter eq_dec: forall (x y: t), { x = y } + { x<>y }. + +End ResourceNames. + + +(** * Parameters of the language of Basic Blocks *) +Module Type LangParam. + +Declare Module R: ResourceNames. + +Parameter value: Type. + +(** Declare the type of operations *) + +Parameter op: Type. (* type of operations *) + +(* NB: possible generalization + - relation after/before. +*) +Parameter op_eval: op -> list value -> option value. + +End LangParam. + + + +(** * Syntax and (sequential) semantics of "basic blocks" *) +Module MkSeqLanguage(P: LangParam). + +Export P. + +Local Open Scope list. + +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. + +Inductive exp := + | Name (x:R.t) + | Op (o:op) (le: list_exp) + | Old (e: exp) +with list_exp := + | Enil + | Econs (e:exp) (le:list_exp) + | LOld (le: list_exp) + . + +Fixpoint exp_eval (e: exp) (m old: mem): option value := + match e with + | Name x => Some (m x) + | Op o le => + match list_exp_eval le m old with + | Some lv => op_eval o lv + | _ => None + end + | Old e => exp_eval e old old + end +with list_exp_eval (le: list_exp) (m old: mem): option (list value) := + match le with + | Enil => Some nil + | Econs e le' => + match exp_eval e m old, list_exp_eval le' m old with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + | LOld le => list_exp_eval le old old + end. + +Definition macro := list (R.t * exp). (* = a sequence of assignments *) + +Fixpoint macro_run (i: macro) (m old: mem): option mem := + match i with + | nil => Some m + | (x, e)::i' => + match exp_eval e m old with + | Some v' => macro_run i' (assign m x v') old + | None => None + end + end. + +Definition bblock := list macro. + +Fixpoint run (p: bblock) (m: mem): option mem := + match p with + | nil => Some m + | i::p' => + match macro_run i m m with + | Some m' => run p' m' + | None => None + end + end. + +(* A few useful lemma *) +Lemma assign_eq m x v: + (assign m x v) x = v. +Proof. + unfold assign. destruct (R.eq_dec x x); try congruence. +Qed. + +Lemma assign_diff m x y v: + x<>y -> (assign m x v) y = m y. +Proof. + unfold assign. destruct (R.eq_dec x y); try congruence. +Qed. + +Lemma assign_skips m x y: + (assign m x (m x)) y = m y. +Proof. + unfold assign. destruct (R.eq_dec x y); try congruence. +Qed. + +Lemma assign_swap m x1 v1 x2 v2 y: + x1 <> x2 -> (assign (assign m x1 v1) x2 v2) y = (assign (assign m x2 v2) x1 v1) y. +Proof. + intros; destruct (R.eq_dec x2 y). + - subst. rewrite assign_eq, assign_diff; auto. rewrite assign_eq; auto. + - rewrite assign_diff; auto. + destruct (R.eq_dec x1 y). + + subst; rewrite! assign_eq. auto. + + rewrite! assign_diff; auto. +Qed. + + +(** A small theory of bblockram equality *) + +(* equalities on bblockram outputs *) +Definition res_eq (om1 om2: option mem): Prop := + match om1 with + | Some m1 => exists m2, om2 = Some m2 /\ forall x, m1 x = m2 x + | None => om2 = None + end. + +Scheme exp_mut := Induction for exp Sort Prop +with list_exp_mut := Induction for list_exp Sort Prop. + +Lemma exp_equiv e old1 old2: + (forall x, old1 x = old2 x) -> + forall m1 m2, (forall x, m1 x = m2 x) -> + (exp_eval e m1 old1) = (exp_eval e m2 old2). +Proof. + intros H1. + induction e using exp_mut with (P0:=fun l => forall m1 m2, (forall x, m1 x = m2 x) -> list_exp_eval l m1 old1 = list_exp_eval l m2 old2); simpl; try congruence; auto. + - intros; erewrite IHe; eauto. + - intros; erewrite IHe, IHe0; auto. +Qed. + +Definition bblock_equiv (p1 p2: bblock): Prop + := forall m, res_eq (run p1 m) (run p2 m). + +Lemma alt_macro_equiv_refl i old1 old2: + (forall x, old1 x = old2 x) -> + forall m1 m2, (forall x, m1 x = m2 x) -> + res_eq (macro_run i m1 old1) (macro_run i m2 old2). +Proof. + intro H; induction i as [ | [x e]]; simpl; eauto. + intros m1 m2 H1. erewrite exp_equiv; eauto. + destruct (exp_eval e m2 old2); simpl; auto. + apply IHi. + unfold assign; intro y. destruct (R.eq_dec x y); auto. +Qed. + +Lemma alt_bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). +Proof. + induction p as [ | i p']; simpl; eauto. + intros m1 m2 H; lapply (alt_macro_equiv_refl i m1 m2); auto. + intros X; lapply (X m1 m2); auto; clear X. + destruct (macro_run i m1 m1); simpl. + - intros [m3 [H1 H2]]; rewrite H1; simpl; auto. + - intros H1; rewrite H1; simpl; auto. +Qed. + +Lemma res_eq_sym om1 om2: res_eq om1 om2 -> res_eq om2 om1. +Proof. + destruct om1; simpl. + - intros [m2 [H1 H2]]; subst; simpl. eauto. + - intros; subst; simpl; eauto. +Qed. + +Lemma res_eq_trans (om1 om2 om3: option mem): + (res_eq om1 om2) -> (res_eq om2 om3) -> (res_eq om1 om3). +Proof. + destruct om1; simpl. + - intros [m2 [H1 H2]]; subst; simpl. + intros [m3 [H3 H4]]; subst; simpl. + eapply ex_intro; intuition eauto. rewrite H2; auto. + - intro; subst; simpl; auto. +Qed. + +Lemma bblock_equiv_alt p1 p2: bblock_equiv p1 p2 <-> (forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p1 m1) (run p2 m2)). +Proof. + unfold bblock_equiv; intuition. + intros; eapply res_eq_trans. eapply alt_bblock_equiv_refl; eauto. + eauto. +Qed. + +End MkSeqLanguage. + + +Module Type SeqLanguage. + +Declare Module LP: LangParam. + +Include MkSeqLanguage LP. + +End SeqLanguage. + diff --git a/mppa_k1c/abstractbb/DepExample.v b/mppa_k1c/abstractbb/DepExample.v new file mode 100644 index 00000000..a239e24f --- /dev/null +++ b/mppa_k1c/abstractbb/DepExample.v @@ -0,0 +1,151 @@ +(** Specification of the example illustrating how to use ImpDep. *) + +Require Export ZArith. + +Require Export ZArith. +Require Export List. +Export ListNotations. + +(* Syntax *) + +Definition reg := positive. + +Inductive operand := + | Imm (i:Z) + | Reg (r:reg) + . + +Inductive arith_op := ADD | SUB | MUL. + +Inductive inst := + | MOVE (dest: reg) (src: operand) + | ARITH (dest: reg) (op: arith_op) (src1 src2: operand) + | LOAD (dest base: reg) (offset: operand) + | STORE (src base: reg) (offset: operand) + | MEMSWAP (r base: reg) (offset: operand) + . + +Definition bblock := list inst. + +(* Semantics *) + +Definition value := Z. + +Definition addr := positive. + +Definition mem := addr -> value. + +Definition assign (m: mem) (x:addr) (v: value) := + fun y => if Pos.eq_dec x y then v else (m y). + +Definition regmem := reg -> value. + +Record state := { sm: mem; rm: regmem }. + +Definition operand_eval (x: operand) (rm: regmem): value := + match x with + | Imm i => i + | Reg r => rm r + end. + +Definition arith_op_eval (o: arith_op): value -> value -> value := + match o with + | ADD => Z.add + | SUB => Z.sub + | MUL => Z.mul + end. + +Definition get_addr (base:reg) (offset:operand) (rm: regmem): option addr := + let b := rm base in + let ofs := operand_eval offset rm in + match Z.add b ofs with + | Zpos p => Some p + | _ => None + end. + +(* two-state semantics -- dissociating read from write access. + - all read access on [sin] state + - all register write access modifies [sout] state + - all memory write access modifies [sin] state + => useful for parallel semantics + NB: in this parallel semantics -- there is at most one STORE by bundle + which is non-deterministically chosen... +*) +Definition sem_inst (i: inst) (sin sout: state): option state := + match i with + | MOVE dest src => + let v := operand_eval src (rm sin) in + Some {| sm := sm sout; + rm := assign (rm sout) dest v |} + | ARITH dest op src1 src2 => + let v1 := operand_eval src1 (rm sin) in + let v2 := operand_eval src2 (rm sin) in + let v := arith_op_eval op v1 v2 in + Some {| sm := sm sout; + rm := assign (rm sout) dest v |} + | LOAD dest base offset => + match get_addr base offset (rm sin) with + | Some srce => + Some {| sm := sm sout; + rm := assign (rm sout) dest (sm sin srce) |} + | None => None + end + | STORE srce base offset => + match get_addr base offset (rm sin) with + | Some dest => + Some {| sm := assign (sm sin) dest (rm sin srce); + rm := rm sout |} + | None => None + end + | MEMSWAP x base offset => + match get_addr base offset (rm sin) with + | Some ad => + Some {| sm := assign (sm sin) ad (rm sin x); + rm := assign (rm sout) x (sm sin ad) |} + | None => None + end + end. + +Local Open Scope list_scope. + +(** usual sequential semantics *) +Fixpoint sem_bblock (p: bblock) (s: state): option state := + match p with + | nil => Some s + | i::p' => + match sem_inst i s s with + | Some s' => sem_bblock p' s' + | None => None + end + end. + +Definition state_equiv (s1 s2: state): Prop := + (forall x, sm s1 x = sm s2 x) /\ + (forall x, rm s1 x = rm s2 x). + +(* equalities on bblockram outputs *) +Definition res_equiv (os1 os2: option state): Prop := + match os1 with + | Some s1 => exists s2, os2 = Some s2 /\ state_equiv s1 s2 + | None => os2 = None + end. + + +Definition bblock_equiv (p1 p2: bblock): Prop := + forall s, res_equiv (sem_bblock p1 s) (sem_bblock p2 s). + +(** parallel semantics with in-order writes *) +Fixpoint sem_bblock_par_iw (p: bblock) (sin sout: state): option state := + match p with + | nil => Some sout + | i::p' => + match sem_inst i sin sout with + | Some sout' => sem_bblock_par_iw p' sin sout' + | None => None + end + end. + +(** parallelism semantics with arbitrary order writes *) +Require Import Sorting.Permutation. + +Definition sem_bblock_par (p: bblock) (sin: state) (sout: option state) := exists p', res_equiv sout (sem_bblock_par_iw p' sin sin) /\ Permutation p p'. diff --git a/mppa_k1c/abstractbb/DepExampleDemo.v b/mppa_k1c/abstractbb/DepExampleDemo.v new file mode 100644 index 00000000..c2079b70 --- /dev/null +++ b/mppa_k1c/abstractbb/DepExampleDemo.v @@ -0,0 +1,396 @@ +(** Demo of the example illustrating how to use ImpDep. *) + +Require Import DepExampleEqTest. +Require Import Bool. + +Open Scope Z_scope. + +Module EqTests. + +(**** TESTS DRIVER ! ****) + +Record test_input := { + name: pstring; + expected: bool; + verbose: bool; + p1: bblock; + p2: bblock; +}. + +Definition run1 (t: test_input): ?? unit := + print ((name t) +; " =>");; + DO result <~ bblock_eq_test (verbose t) (p1 t) (p2 t);; + assert_b (eqb result (expected t)) "UNEXPECTED RESULT";; + if expected t + then println " SUCCESS" + else RET tt (* NB: in this case - bblock_eq_test is expected to have print an ERROR mesg *) + . + +Local Hint Resolve eqb_prop. + +Lemma run1_correctness (t: test_input): + WHEN run1 t ~> _ THEN (expected t)=true -> bblock_equiv (p1 t) (p2 t). +Proof. + unfold run1; destruct t; simpl; wlp_simplify; subst. +Qed. +Global Opaque run1. +Hint Resolve run1_correctness: wlp. + +Fixpoint run_all (l: list test_input): ?? unit := + match l with + | nil => RET tt + | t::l' => + println "" ;; (* SOME SPACES ! *) + run1 t;; + run_all l' + end. + +Lemma run_all_correctness l: + WHEN run_all l ~> _ THEN (forall t, List.In t l -> (expected t)=true -> bblock_equiv (p1 t) (p2 t)). +Proof. + induction l; simpl; wlp_simplify; subst; auto. +Qed. +Global Opaque run_all. + +(**** TESTS ****) + +Definition move (dst src: reg) := MOVE dst (Reg src). +Definition add_imm (dst src: reg) (z:Z) := ARITH dst ADD (Reg src) (Imm z). +Definition incr (r: reg) (z:Z) := add_imm r r z. +Definition add (dst src1 src2: reg) := ARITH dst ADD (Reg src1) (Reg src2). + +Definition load (dst src:reg) (ofs:Z) := LOAD dst src (Imm ofs). +Definition store (src dst:reg) (ofs:Z) := STORE src dst (Imm ofs). +Definition memswap (r base:reg) (ofs:Z) := MEMSWAP r base (Imm ofs). + +Definition R1: reg := 1%positive. +Definition R2: reg := 2%positive. +Definition R3: reg := 3%positive. +Definition R4: reg := 4%positive. + + +Definition demo: ?? unit := run_all [ + + {| name:="move_ok" ; + expected:=true; + verbose:=true; + p1:=[ move R2 R1; move R3 R1 ]; + p2:=[ move R3 R1; move R2 R3 ]; + |} ; + {| name:="move_ko" ; + expected:=false; + verbose:=true; + p1:=[ move R2 R1; move R3 R1 ]; + p2:=[ move R3 R1 ]; + |} ; + + {| name:="add_load_RAR_ok" ; + expected:=true; + verbose:=true; + p1:=[ add_imm R1 R2 5; move R4 R2; load R3 R2 2 ]; + p2:=[ load R3 R2 2; add_imm R1 R2 5; move R4 R2 ]; |} ; + + {| name:="add_load_RAW_ko"; + expected:=false; + verbose:=true; + p1:=[ add_imm R1 R2 5; move R4 R2; load R3 R1 2 ]; + p2:=[ load R3 R1 2; add_imm R1 R2 5; move R4 R2 ]; |} ; + + {| name:="add_load_WAW_ko"; + expected:=false; + verbose:=true; + p1:=[ add_imm R3 R2 5; move R4 R2; load R3 R1 2 ]; + p2:=[ load R3 R1 2; add_imm R3 R2 5; move R4 R2 ]; |} ; + + {| name:="memswap_ok1"; + expected:=true; + verbose:=true; + p1:=[ add_imm R1 R2 5; memswap R3 R2 2 ]; + p2:=[ memswap R3 R2 2; add_imm R1 R2 5 ]; |} ; + + {| name:="memswap_ok2" ; + expected:=true; + verbose:=true; + p1:=[ load R1 R2 2; store R3 R2 2; move R3 R1]; + p2:=[ memswap R3 R2 2 ; move R1 R3 ]; + |} ; + + {| name:="memswap_ko" ; + expected:=false; + verbose:=true; + p1:=[ load R3 R2 2; store R3 R2 2]; + p2:=[ memswap R3 R2 2 ]; + |} +]. + + +Fixpoint repeat_aux (n:nat) (rev_body next: bblock): bblock := + match n with + | O => next + | (S n) => repeat_aux n rev_body (List.rev_append rev_body next) + end. + +Definition repeat n body next := repeat_aux n (List.rev_append body []) next. + + +Definition inst1 := add R1 R1 R2. + +(* NB: returns [inst1^10; next] *) +Definition dummy1 next:= repeat 10%nat [inst1] next. + +Definition main: ?? unit := run_all [ + + {| name:="move_never_skips1" ; + expected:=false; + verbose:=false; + p1:=[ move R2 R2 ]; + p2:=[ ]; + |} ; + + {| name:="move_compress_ok" ; + expected:=true; + verbose:=false; + p1:=[ move R1 R2; move R2 R1; MOVE R1 (Imm 7) ]; + p2:=[ MOVE R1 (Imm 7); move R2 R2 ]; + |} ; + + {| name:="move_never_skip2" ; + expected:=false; + verbose:=false; + p1:=[ move R1 R2; move R2 R1; MOVE R1 (Imm 7) ]; + p2:=[ MOVE R1 (Imm 7) ]; + |} ; + + {| name:="R2_RAR_ok1"; + expected:=true; + verbose:=false; + p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; + p2:=load R3 R2 2::store R3 R4 7::(dummy1 nil) |} ; + {| name:="R2_RAR_ok2"; + expected:=true; + verbose:=false; + p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; + p2:=load R3 R2 2::(dummy1 [store R3 R4 7]) |} ; + {| name:="R2_RAR_ok3"; + expected:=true; + verbose:=false; + p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; + p2:=load R3 R2 2::(repeat 4%nat [inst1;inst1] [store R3 R4 7; inst1; inst1]) |} ; + {| name:="bad_register_name_ko"; + expected:=false; + verbose:=false; + p1:=dummy1 [ load R3 R2 2 ]; + p2:=dummy1 [ load R3 R3 2 ] |} ; + {| name:="bad_instruction_ko"; + expected:=false; + verbose:=false; + p1:=dummy1 [ load R3 R2 2 ]; + p2:=dummy1 [ store R3 R2 2 ] |} ; + {| name:="incompleteness_ko"; + expected:=false; + verbose:=false; + p1:=dummy1 [ load R3 R2 2 ]; + p2:=[inst1; load R3 R2 2] |} ; + + + {| name:="R2_WAR_ko"; + expected:=false; + verbose:=false; + p1:=dummy1 [ load R2 R3 2 ]; + p2:=load R2 R3 2::(dummy1 nil) |} ; + {| name:="bad_register_name_ko2"; + expected:=false; + verbose:=false; + p1:=dummy1 [ load R2 R3 2 ]; + p2:=load R3 R2 2::(dummy1 nil) |} ; + + + {| name:="load_RAR_ok1"; + expected:=true; + verbose:=false; + p1:=[ load R1 R2 2; load R3 R4 5]; + p2:=[ load R3 R4 5; load R1 R2 2]; |} ; + {| name:="load_RAR_ok2"; + expected:=true; + verbose:=false; + p1:=[ load R1 R2 2; load R3 R2 5]; + p2:=[ load R3 R2 5; load R1 R2 2]; |} ; + {| name:="load_WAW_ko"; + expected:=false; + verbose:=false; + p1:=[ load R1 R2 2; load R1 R4 5]; + p2:=[ load R1 R4 5; load R1 R2 2]; |} ; + {| name:="load_store_WAR_ko"; + expected:=false; + verbose:=false; + p1:=[ load R1 R2 2; store R3 R4 5]; + p2:=[ store R3 R4 5; load R1 R2 2]; |} + + ]. + +Definition incr_R1_5 := incr R1 5. +Definition incr_R2_3 := incr R2 3. + +Definition big_test (bigN:nat) (name: pstring): ?? unit := + println "";; + println("---- Time of bigtest " +; name);; + timer(run_all, [ + + {| name:="big_test_ok1"; + expected:=true; + verbose:=false; + p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; + p2:=repeat bigN [incr_R1_5] (repeat (S bigN) [incr_R2_3] nil) |} ; + {| name:="big_test_ok2"; + expected:=true; + verbose:=false; + p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; + p2:=repeat bigN [incr_R2_3;incr_R1_5] [incr_R2_3] |} ; + {| name:="big_test_ok3"; + expected:=true; + verbose:=false; + p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; + p2:=repeat (S bigN) [incr_R2_3] (repeat bigN [incr_R1_5] nil) |} ; + {| name:="big_test_ko1"; + expected:=false; + verbose:=false; + p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; + p2:=repeat bigN [incr_R1_5] (repeat bigN [incr_R2_3] nil) |} ; + {| name:="big_test_ko2"; + expected:=false; + verbose:=false; + p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; + p2:=repeat (S bigN) [incr_R1_5] (repeat bigN [incr_R2_3] nil) |} + + ]). + +Fixpoint big_tests (l:list (nat * string)) := + match l with + | nil => RET tt + | (x,s)::l' => big_test x s;; big_tests l' + end. + +Local Open Scope nat_scope. +Local Open Scope string_scope. + +Definition big_runs: ?? unit := + big_tests [(2500, "2500"); (5000, "5000"); (10000, "10000"); (20000, "20000")]. + + +End EqTests. + + +Require Import DepExampleParallelTest. + +Module ParaTests. + + +(**** TESTS DRIVER ! ****) + +Record test_input := { + name: pstring; + expected: bool; + bundle: bblock; +}. + +Definition run1 (t: test_input): ?? unit := + print ((name t) +; " =>");; + assert_b (eqb (bblock_is_para (bundle t)) (expected t)) "UNEXPECTED RESULT";; + if expected t + then println " SUCCESS" + else println " FAILED (as expected)" + . + +Local Hint Resolve eqb_prop. + +Definition correct_bundle p := forall s os', (sem_bblock_par p s os' <-> res_equiv os' (sem_bblock p s)). + +Lemma run1_correctness (t: test_input): + WHEN run1 t ~> _ THEN (expected t)=true -> correct_bundle (bundle t). +Proof. + unfold run1; destruct t; simpl; wlp_simplify; subst. + - unfold correct_bundle; intros; apply bblock_is_para_correct; auto. + - discriminate. +Qed. +Global Opaque run1. +Hint Resolve run1_correctness: wlp. + +Fixpoint run_all (l: list test_input): ?? unit := + match l with + | nil => RET tt + | t::l' => + run1 t;; + run_all l' + end. + +Lemma run_all_correctness l: + WHEN run_all l ~> _ THEN (forall t, List.In t l -> (expected t)=true -> correct_bundle (bundle t)). +Proof. + induction l; simpl; wlp_simplify; subst; auto. +Qed. +Global Opaque run_all. + +(**** TESTS ****) + +Definition add_imm (dst src: reg) (z:Z) := ARITH dst ADD (Reg src) (Imm z). + +Definition load (dst src:reg) (ofs:Z) := LOAD dst src (Imm ofs). +Definition store (src dst:reg) (ofs:Z) := STORE src dst (Imm ofs). +Definition memswap (r base:reg) (ofs:Z) := MEMSWAP r base (Imm ofs). + +Definition R1: reg := 1%positive. +Definition R2: reg := 2%positive. +Definition R3: reg := 3%positive. +Definition R4: reg := 4%positive. +Definition R5: reg := 5%positive. +Definition R6: reg := 5%positive. + + +Definition main: ?? unit := + println "";; + println "-- Parallel Checks --";; + run_all [ + {| name:="test_war_ok"; + expected:=true; + bundle:=[add_imm R1 R2 2;add_imm R2 R2 3] + |}; + {| name:="test_raw_ko"; + expected:=false; + bundle:=[add_imm R1 R2 2;add_imm R2 R1 3] + |}; + {| name:="test_waw_ko"; + expected:=false; + bundle:=[add_imm R1 R2 2;add_imm R1 R2 3] + |}; + {| name:="test_war_load_store_ok"; + expected:=true; + bundle:=[load R1 R2 2;load R2 R3 3; store R3 R4 4] + |}; + {| name:="test_raw_load_store_ko"; + expected:=false; + bundle:=[load R1 R2 2;store R5 R4 4;load R2 R3 3] + |}; + {| name:="test_waw_load_store_ko"; + expected:=false; + bundle:=[load R1 R2 2;store R3 R2 3;store R5 R4 4] + |}; + {| name:="test_arith_load_store_ok"; + expected:=true; + bundle:=[load R1 R2 2; add_imm R2 R4 3; load R3 R6 3; add_imm R4 R4 3; store R6 R5 4; add_imm R6 R6 7] + |} + ]. + +End ParaTests. + +(*************************) +(* Extraction directives *) + +Require Import ExtrOcamlString. +Require Import ExtrOcamlBasic. + +Import ImpConfig. + +Extraction Blacklist List String. + +Separate Extraction BinIntDef EqTests ParaTests. + diff --git a/mppa_k1c/abstractbb/DepExampleEqTest.v b/mppa_k1c/abstractbb/DepExampleEqTest.v new file mode 100644 index 00000000..50bfc2f4 --- /dev/null +++ b/mppa_k1c/abstractbb/DepExampleEqTest.v @@ -0,0 +1,326 @@ +(** Implementation of the example illustrating how to use ImpDep. *) + +Require Export DepExample. +Require Export Impure.ImpIO. +Export Notations. + +Require Import ImpDep. + +Open Scope impure. + +Module P<: ImpParam. + +Module R := Pos. + +Inductive value_wrap := + | Std (v:value) (* value = DepExample.value *) + | Mem (m:mem) + . + +Inductive op_wrap := + (* constants *) + | Imm (i:Z) + (* arithmetic operation *) + | ARITH (op: arith_op) + | LOAD + | STORE + . + +Definition op_eval (op: op_wrap) (l:list value_wrap): option value_wrap := + match op, l with + | Imm i, [] => Some (Std i) + | ARITH op, [Std v1; Std v2] => Some (Std (arith_op_eval op v1 v2)) + | LOAD, [Mem m; Std base; Std offset] => + match (Z.add base offset) with + | Zpos srce => Some (Std (m srce)) + | _ => None + end + | STORE, [Mem m; Std srce; Std base; Std offset] => + match (Z.add base offset) with + | Zpos dest => Some (Mem (assign m dest srce)) + | _ => None + end + | _, _ => None + end. + + +Definition value:=value_wrap. +Definition op:=op_wrap. + + +Definition op_eq (o1 o2: op_wrap): ?? bool := + match o1, o2 with + | Imm i1, Imm i2 => phys_eq i1 i2 + | ARITH o1, ARITH o2 => phys_eq o1 o2 + | LOAD, LOAD => RET true + | STORE, STORE => RET true + | _, _ => RET false + end. + +Lemma op_eq_correct o1 o2: + WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; congruence. +Qed. + +End P. + + +Module L <: ISeqLanguage with Module LP:=P. + +Module LP:=P. + +Include MkSeqLanguage P. + +End L. + + +Module IDT := ImpDepTree L ImpPosDict. + +(** Compilation from DepExample to L *) + +Definition the_mem: P.R.t := 1. +Definition reg_map (r: reg): P.R.t := Pos.succ r. + +Coercion L.Name: P.R.t >-> L.exp. + +Definition comp_op (o:operand): L.exp := + match o with + | Imm i => L.Op (P.Imm i) L.Enil + | Reg r => reg_map r + end. + +Definition comp_inst (i: inst): L.macro := + match i with + | MOVE dest src => + [ (reg_map dest, (comp_op src)) ] + | ARITH dest op src1 src2 => + [ (reg_map dest, L.Op (P.ARITH op) (L.Econs (comp_op src1) (L.Econs (comp_op src2) L.Enil))) ] + | LOAD dest base offset => + [ (reg_map dest, L.Op P.LOAD (L.Econs the_mem (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))) ] + | STORE srce base offset => + [ (the_mem, L.Op P.STORE (L.Econs the_mem (L.Econs (reg_map srce) (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil))))) ] + | MEMSWAP x base offset => + [ (reg_map x, L.Op P.LOAD (L.Econs the_mem (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))); + (the_mem, L.Old (L.Op P.STORE (L.Econs the_mem (L.Econs (reg_map x) (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))))) ] + end. + +Fixpoint comp_bblock (p: bblock): L.bblock := + match p with + | nil => nil + | i::p' => (comp_inst i)::(comp_bblock p') + end. + +(** Correctness proof of the compiler *) + +Lemma the_mem_separation: forall r, reg_map r <> the_mem. +Proof. + intros r; apply Pos.succ_not_1. +Qed. + +Lemma reg_map_separation: forall r1 r2, r1 <> r2 -> reg_map r1 <> reg_map r2. +Proof. + unfold reg_map; intros r1 r2 H1 H2; lapply (Pos.succ_inj r1 r2); auto. +Qed. + +Local Hint Resolve the_mem_separation reg_map_separation. + +Definition match_state (s: state) (m:L.mem): Prop := + m the_mem = P.Mem (sm s) /\ forall r, m (reg_map r) = P.Std (rm s r). + +Definition trans_state (s: state): L.mem := + fun x => + if Pos.eq_dec x the_mem + then P.Mem (sm s) + else P.Std (rm s (Pos.pred x)). + +Lemma match_trans_state (s:state): match_state s (trans_state s). +Proof. + unfold trans_state; constructor 1. + - destruct (Pos.eq_dec the_mem the_mem); try congruence. + - intros r; destruct (Pos.eq_dec (reg_map r) the_mem). + * generalize the_mem_separation; subst; congruence. + * unfold reg_map; rewrite Pos.pred_succ. auto. +Qed. + +Definition match_option_state (os: option state) (om:option L.mem): Prop := + match os with + | Some s => exists m, om = Some m /\ match_state s m + | None => om = None + end. + +Lemma comp_op_correct o s m old: match_state s m -> L.exp_eval (comp_op o) m old = Some (P.Std (operand_eval o (rm s))). +Proof. + destruct 1 as [H1 H2]; destruct o; simpl; auto. + rewrite H2; auto. +Qed. + +Lemma comp_bblock_correct_aux p: forall s m, match_state s m -> match_option_state (sem_bblock p s) (L.run (comp_bblock p) m). +Proof. + induction p as [| i p IHp]; simpl; eauto. + intros s m H; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. + - (* MOVE *) + apply IHp. + destruct H as [H1 H2]; constructor 1; simpl. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* ARITH *) + apply IHp. + destruct H as [H1 H2]; constructor 1; simpl. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* LOAD *) + destruct H as [H1 H2]. + rewrite H1, H2; simpl. + unfold get_addr. + destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. + apply IHp. + constructor 1; simpl. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* STORE *) + destruct H as [H1 H2]. + rewrite H1, !H2; simpl. + unfold get_addr. + destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. + apply IHp. + constructor 1; simpl; auto. + + intros r; rewrite L.assign_diff; auto. + - (* MEMSWAP *) + destruct H as [H1 H2]. + rewrite H1, !H2; simpl. + unfold get_addr. + destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. + apply IHp. + constructor 1; simpl; auto. + intros r0; rewrite L.assign_diff; auto. + unfold assign; destruct (Pos.eq_dec r r0). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. +Qed. + +Lemma comp_bblock_correct p s: match_option_state (sem_bblock p s) (L.run (comp_bblock p) (trans_state s)). +Proof. + eapply comp_bblock_correct_aux. apply match_trans_state. +Qed. + +Lemma state_equiv_from_match (s1 s2: state) (m: L.mem) : + (match_state s1 m) -> (match_state s2 m) -> (state_equiv s1 s2). +Proof. + unfold state_equiv, match_state. intuition. + - congruence. + - assert (P.Std (rm s1 x) = P.Std (rm s2 x)); congruence. +Qed. + +Definition match_option_stateX (om:option L.mem) (os:option state): Prop := + match om with + | Some m => exists s, os = Some s /\ match_state s m + | None => os = None + end. + +Local Hint Resolve state_equiv_from_match. + +Lemma res_equiv_from_match (os1 os2: option state) (om: option L.mem): + (match_option_state os1 om) -> (match_option_stateX om os2) -> (res_equiv os1 os2). +Proof. + destruct os1 as [s1|]; simpl. + - intros [m [H1 H2]]; subst; simpl. + intros [s2 [H3 H4]]; subst; simpl. + eapply ex_intro; intuition eauto. + - intro; subst; simpl; auto. +Qed. + + +Lemma match_option_state_intro_X om os: match_option_state os om -> match_option_stateX om os. +Proof. + destruct os as [s | ]; simpl. + - intros [m [H1 H2]]. subst; simpl. eapply ex_intro; intuition eauto. + - intros; subst; simpl; auto. +Qed. + + +Lemma match_from_res_eq om1 om2 os: + L.res_eq om2 om1 -> match_option_stateX om1 os -> match_option_stateX om2 os. +Proof. + destruct om2 as [m2 | ]; simpl. + - intros [m [H1 H2]]. subst; simpl. + intros [s [H3 H4]]; subst; simpl. + eapply ex_intro; intuition eauto. + unfold match_state in * |- *. + intuition (rewrite H2; auto). + - intros; subst; simpl; auto. +Qed. + +Lemma bblock_equiv_reduce p1 p2: L.bblock_equiv (comp_bblock p1) (comp_bblock p2) -> bblock_equiv p1 p2. +Proof. + unfold L.bblock_equiv, bblock_equiv. + intros; eapply res_equiv_from_match. + apply comp_bblock_correct. + eapply match_from_res_eq. eauto. + apply match_option_state_intro_X. + apply comp_bblock_correct. +Qed. + + + + +(* NB: pretty-printing functions below only mandatory for IDT.verb_bblock_eq_test *) +Local Open Scope string_scope. + +Definition string_of_name (x: P.R.t): ?? pstring := + match x with + | xH => RET (Str ("the_mem")) + | _ as x => + DO s <~ string_of_Z (Zpos (Pos.pred x)) ;; + RET ("R" +; s) + end. + +Definition string_of_op (op: P.op): ?? pstring := + match op with + | P.Imm i => + DO s <~ string_of_Z i ;; + RET s + | P.ARITH ADD => RET (Str "ADD") + | P.ARITH SUB => RET (Str "SUB") + | P.ARITH MUL => RET (Str "MUL") + | P.LOAD => RET (Str "LOAD") + | P.STORE => RET (Str "STORE") + end. + +Definition bblock_eq_test (verb: bool) (p1 p2: bblock) : ?? bool := + if verb then + IDT.verb_bblock_eq_test string_of_name string_of_op (comp_bblock p1) (comp_bblock p2) + else + IDT.bblock_eq_test (comp_bblock p1) (comp_bblock p2). + +Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. + + +Theorem bblock_eq_test_correct verb p1 p2 : + WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque bblock_eq_test. +Hint Resolve bblock_eq_test_correct: wlp. + +(* TEST: we can coerce this bblock_eq_test into a pure function (even if this is a little unsafe). *) +(* +Import UnsafeImpure. + +Definition pure_eq_test v (p1 p2: bblock) : bool := unsafe_coerce (bblock_eq_test v p1 p2). + +Theorem pure_eq_test_correct v p1 p2 : + pure_eq_test v p1 p2 = true -> bblock_equiv p1 p2. +Proof. + unfold pure_eq_test. intros; eapply bblock_eq_test_correct. + - apply unsafe_coerce_not_really_correct; eauto. + - eauto. +Qed. +*) \ No newline at end of file diff --git a/mppa_k1c/abstractbb/DepExampleParallelTest.v b/mppa_k1c/abstractbb/DepExampleParallelTest.v new file mode 100644 index 00000000..00f33540 --- /dev/null +++ b/mppa_k1c/abstractbb/DepExampleParallelTest.v @@ -0,0 +1,161 @@ +Require Import DepExampleEqTest. +Require Import Parallelizability. + +Module PChk := ParallelChecks L PosResourceSet. + +Definition bblock_is_para (p: bblock) : bool := + PChk.is_parallelizable (comp_bblock p). + +Local Hint Resolve the_mem_separation reg_map_separation. + +(* Actually, almost the same proof script than [comp_bblock_correct_aux] ! + We could definitely factorize the proof through a lemma on compilation to macros. +*) +Lemma comp_bblock_correct_para_iw p: forall sin sout min mout, + match_state sin min -> + match_state sout mout -> + match_option_state (sem_bblock_par_iw p sin sout) (PChk.prun_iw (comp_bblock p) mout min). +Proof. + induction p as [|i p IHp]; simpl; eauto. + intros sin sout min mout Hin Hout; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. + - (* MOVE *) + apply IHp; auto. + destruct Hin as [H1 H2]; destruct Hout as [H3 H4]; constructor 1; simpl; auto. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* ARITH *) + apply IHp; auto. + destruct Hin as [H1 H2]; destruct Hout as [H3 H4]; constructor 1; simpl; auto. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* LOAD *) + destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. + rewrite H1, H2; simpl. + unfold get_addr. + destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. + apply IHp. { constructor 1; auto. } + constructor 1; simpl. + + rewrite L.assign_diff; auto. + + unfold assign; intros r; destruct (Pos.eq_dec dest r). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. + - (* STORE *) + destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. + rewrite H1, !H2; simpl. + unfold get_addr. + destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. + apply IHp. { constructor 1; auto. } + constructor 1; simpl; auto. + intros r; rewrite L.assign_diff; auto. + - (* MEMSWAP *) + destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. + rewrite H1, !H2; simpl. + unfold get_addr. + destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. + apply IHp. { constructor 1; auto. } + constructor 1; simpl; auto. + + intros r0; rewrite L.assign_diff; auto. + unfold assign; destruct (Pos.eq_dec r r0). + * subst; rewrite L.assign_eq; auto. + * rewrite L.assign_diff; auto. +Qed. + +Local Hint Resolve match_trans_state. + +Definition trans_option_state (os: option state): option L.mem := + match os with + | Some s => Some (trans_state s) + | None => None + end. + +Lemma match_trans_option_state os: match_option_state os (trans_option_state os). +Proof. + destruct os; simpl; eauto. +Qed. + +Local Hint Resolve match_trans_option_state comp_bblock_correct match_option_state_intro_X match_from_res_eq res_equiv_from_match. + +Lemma is_mem_reg (x: P.R.t): x=the_mem \/ exists r, x=reg_map r. +Proof. + case (Pos.eq_dec x the_mem); auto. + unfold the_mem, reg_map; constructor 2. + eexists (Pos.pred x). rewrite Pos.succ_pred; auto. +Qed. + +Lemma res_eq_from_match (os: option state) (om1 om2: option L.mem): + (match_option_stateX om1 os) -> (match_option_state os om2) -> (L.res_eq om1 om2). +Proof. + destruct om1 as [m1|]; simpl. + - intros (s & H1 & H2 & H3); subst; simpl. + intros (m2 & H4 & H5 & H6); subst; simpl. + eapply ex_intro; intuition eauto. + destruct (is_mem_reg x) as [H|(r & H)]; subst; congruence. + - intro; subst; simpl; auto. +Qed. + +(* We use axiom of functional extensionality ! *) +Require Coq.Logic.FunctionalExtensionality. + +Lemma match_from_res_equiv os1 os2 om: + res_equiv os2 os1 -> match_option_state os1 om -> match_option_state os2 om. +Proof. + destruct os2 as [s2 | ]; simpl. + - intros (s & H1 & H2 & H3). subst; simpl. + intros (m & H4 & H5 & H6); subst; simpl. + eapply ex_intro; intuition eauto. + constructor 1. + + rewrite H5; apply f_equal; eapply FunctionalExtensionality.functional_extensionality; auto. + + congruence. + - intros; subst; simpl; auto. +Qed. + + +Require Import Sorting.Permutation. + +Local Hint Constructors Permutation. + +Lemma comp_bblock_Permutation p p': Permutation p p' -> Permutation (comp_bblock p) (comp_bblock p'). +Proof. + induction 1; simpl; eauto. +Qed. + +Lemma comp_bblock_Permutation_back p1 p1': Permutation p1 p1' -> + forall p, p1=comp_bblock p -> + exists p', p1'=comp_bblock p' /\ Permutation p p'. +Proof. + induction 1; simpl; eauto. + - destruct p as [|i p]; simpl; intro X; inversion X; subst. + destruct (IHPermutation p) as (p' & H1 & H2); subst; auto. + eexists (i::p'). simpl; eauto. + - destruct p as [|i1 p]; simpl; intro X; inversion X as [(H & H1)]; subst; clear X. + destruct p as [|i2 p]; simpl; inversion_clear H1. + eexists (i2::i1::p). simpl; eauto. + - intros p H1; destruct (IHPermutation1 p) as (p' & H2 & H3); subst; auto. + destruct (IHPermutation2 p') as (p'' & H4 & H5); subst; eauto. +Qed. + +Local Hint Resolve comp_bblock_Permutation res_eq_from_match match_from_res_equiv comp_bblock_correct_para_iw. + +Lemma bblock_par_iff_prun p s os': + sem_bblock_par p s os' <-> PChk.prun (comp_bblock p) (trans_state s) (trans_option_state os'). +Proof. + unfold sem_bblock_par, PChk.prun. constructor 1. + - intros (p' & H1 & H2). + eexists (comp_bblock p'); intuition eauto. + - intros (p' & H1 & H2). + destruct (comp_bblock_Permutation_back _ _ H2 p) as (p0 & H3 & H4); subst; auto. + eexists p0; constructor 1; eauto. +Qed. + +Theorem bblock_is_para_correct p: + bblock_is_para p = true -> forall s os', (sem_bblock_par p s os' <-> res_equiv os' (sem_bblock p s)). +Proof. + intros H; generalize (PChk.is_parallelizable_correct _ H); clear H. + intros H s os'. + rewrite bblock_par_iff_prun, H. + constructor; eauto. +Qed. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v new file mode 100644 index 00000000..3dff22e1 --- /dev/null +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -0,0 +1,411 @@ +(** Dependency Trees of Abstract Basic Blocks + +with a purely-functional-but-exponential equivalence test. + +*) + + +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. + + +Module Type ResourceDictionary. + +Declare Module R: ResourceNames. + +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 ResourceDictionary. + + +(** * Computations of "bblock" Dependencies and application to the equality test *) + +Module DepTree (L: SeqLanguage) (Dict: ResourceDictionary with Module R:=L.LP.R). + +Export L. +Export LP. +Local Open Scope list. + + +(** 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) + | Terase (new old:tree) (* assignment in the resource: [new] replaces [old] *) +with list_tree := + | Tnil: list_tree + | Tcons (t:tree) (l:list_tree): list_tree + . + + +Fixpoint tree_eval (t: tree) (m: mem): option value := + match t with + | Tname x => Some (m x) + | Top o l => + match list_tree_eval l m with + | Some v => op_eval o v + | _ => None + end + | Terase new old => + (* NB: we simply check whether the old computations has aborted *) + match tree_eval old m with + | Some _ => tree_eval new m + | _ => None + end + end +with list_tree_eval (l: list_tree) (m: mem) {struct l}: option (list value) := + match l with + | Tnil => Some nil + | Tcons t l' => + match (tree_eval t m), (list_tree_eval l' m) with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + +Definition deps:= Dict.t tree. + +Definition deps_get (d:deps) x := + match Dict.get d x with + | None => Tname x + | Some t => t + end. + +Lemma set_spec_eq d x t: + deps_get (Dict.set d x t) x = t. +Proof. + unfold deps_get; rewrite Dict.set_spec_eq; simpl; auto. +Qed. + +Lemma set_spec_diff d x y t: + x <> y -> deps_get (Dict.set d x t) y = deps_get d y. +Proof. + unfold deps_get; intros; rewrite Dict.set_spec_diff; simpl; auto. +Qed. + +Lemma empty_spec x: deps_get Dict.empty x = Tname x. +Proof. + unfold deps_get; rewrite Dict.empty_spec; simpl; auto. +Qed. + +Hint Rewrite set_spec_eq empty_spec: dict_rw. + +Fixpoint exp_tree (e: exp) (d old: deps): tree := + match e with + | Name 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: deps): 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. + +Definition failsafe (t: tree): bool := + match t with + | Tname x => true + | Top o Tnil => + match op_eval o nil with + | Some _ => true + | None => false + end + | _ => false + end. + +Lemma failsafe_correct (t: tree) m: failsafe t = true -> tree_eval t m <> None. +Proof. + destruct t; simpl; try congruence. + destruct l; simpl; try congruence. + destruct (op_eval o nil); try congruence. +Qed. + +Fixpoint macro_deps (i: macro) (d old: deps): deps := + match i with + | nil => d + | (x, e)::i' => + let t0:=deps_get d x in + let t1:=exp_tree e d old in + let v':=if failsafe t0 then t1 else (Terase t1 t0) in + macro_deps i' (Dict.set d x v') old + end. + +Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps := + match p with + | nil => d + | i::p' => + let d':=macro_deps i d d in + bblock_deps_rec p' d' + end. + +Definition bblock_deps: bblock -> deps + := fun p => bblock_deps_rec p Dict.empty. + +(** Main Result: the [bblock_deps_equiv] theorem states that bblocks with the same dependencies are observationaly equals *) + + +Lemma tree_eval_exp e od m0 old: + (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> + forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + (tree_eval (exp_tree e d od) m0) = exp_eval e m1 old. +Proof. + intro H. + induction e using exp_mut with (P0:=fun l => forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval (list_exp_tree l d od) m0 = list_exp_eval l m1 old); simpl; auto. + - intros; erewrite IHe; eauto. + - intros; erewrite IHe, IHe0; eauto. +Qed. + +Lemma tree_eval_macro_abort i m0 x old: forall d, + tree_eval (deps_get d x) m0 = None -> + tree_eval (deps_get (macro_deps i d old) x) m0 = None. +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d H; erewrite IHi; eauto. clear IHi. + destruct (R.eq_dec x y). + * subst; autorewrite with dict_rw. + generalize (failsafe_correct (deps_get d y) m0). + destruct (failsafe (deps_get d y)); simpl; intuition try congruence. + rewrite H; simpl. auto. + * rewrite! set_spec_diff; auto. +Qed. + +Lemma tree_eval_abort p m0 x: forall d, + tree_eval (deps_get d x) m0 = None -> + tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. +Proof. + induction p; simpl; auto. + intros d H; erewrite IHp; eauto. clear IHp. + eapply tree_eval_macro_abort; eauto. +Qed. + +Lemma tree_eval_macro_Some_correct1 i m0 old od: + (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> + forall (m1 m2: mem) d, + macro_run i m1 old = Some m2 -> + (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + (forall x, tree_eval (deps_get (macro_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. + remember (exp_eval e m1 old) as ov. + destruct ov. + + refine (IHi _ _ _ _ _ _); eauto. + clear x0; intros x0. + unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; + erewrite tree_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + inversion H. +Qed. + +Local Hint Resolve tree_eval_macro_Some_correct1 tree_eval_abort. + +Lemma tree_eval_Some_correct1 p m0: forall (m1 m2: mem) d, + run p m1 = Some m2 -> + (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)). +Proof. + induction p as [ | i p]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + remember (macro_run i m1 m1) as om. + destruct om. + + refine (IHp _ _ _ _ _ _); eauto. + + inversion H. +Qed. + +Lemma bblock_deps_Some_correct1 p m0 m1: + run p m0 = Some m1 + -> forall x, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x). +Proof. + intros; eapply tree_eval_Some_correct1; + intros; autorewrite with dict_rw; simpl; eauto. +Qed. + +Lemma tree_eval_macro_None_correct i m0 old od: + (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> + forall m1 d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + macro_run i m1 old = None <-> exists x, tree_eval (deps_get (macro_deps i d od) x) m0 = None. +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. + - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. + - intros H0. + remember (exp_eval e m1 old) as ov. + destruct ov. + + refine (IHi _ _ _); eauto. + intros x0; unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; + erewrite tree_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + intuition. + constructor 1 with (x:=x); simpl. + apply tree_eval_macro_abort. + autorewrite with dict_rw. + destruct (failsafe (deps_get d x)); simpl; try rewrite H0; + erewrite tree_eval_exp; eauto. +Qed. + + +Lemma tree_eval_None_correct p m0: forall m1 d, + (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + run p m1 = None <-> exists x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. +Proof. + induction p as [|i p IHp]; simpl; intros m1 d. + - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. + - intros H0. + remember (macro_run i m1 m1) as om. + destruct om. + + refine (IHp _ _ _); eauto. + + intuition. + assert (X: macro_run i m1 m1 = None); auto. + rewrite tree_eval_macro_None_correct in X; auto. + destruct X as [x H1]. + constructor 1 with (x:=x); simpl; auto. +Qed. + +Lemma bblock_deps_None_correct p m: + run p m = None <-> exists x, tree_eval (deps_get (bblock_deps p) x) m = None. +Proof. + intros; eapply tree_eval_None_correct. + intros; autorewrite with dict_rw; simpl; eauto. +Qed. + +Lemma tree_eval_macro_Some_correct2 i m0 old od: + (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> + forall (m1 m2: mem) d, + (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + (forall x, tree_eval (deps_get (macro_deps i d od) x) m0 = Some (m2 x)) -> + res_eq (Some m2) (macro_run i m1 old). +Proof. + intro X. + induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + remember (exp_eval e m1 old) as ov. + destruct ov. + + refine (IHi _ _ _ _ _); eauto. + intros x0; unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; + erewrite tree_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + generalize (H x). + rewrite tree_eval_macro_abort; try discriminate. + autorewrite with dict_rw. + destruct (failsafe (deps_get d x)); simpl; try rewrite H0; + erewrite tree_eval_exp; eauto. +Qed. + +Lemma tree_eval_Some_correct2 p m0: forall (m1 m2: mem) d, + (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> + (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)) -> + res_eq (Some m2) (run p m1). +Proof. + induction p as [|i p]; simpl; intros m1 m2 d H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + remember (macro_run i m1 m1) as om. + destruct om. + + refine (IHp _ _ _ _ _); eauto. + + assert (X: macro_run i m1 m1 = None); auto. + rewrite tree_eval_macro_None_correct in X; auto. + destruct X as [x H1]. + generalize (H x). + rewrite tree_eval_abort; congruence. +Qed. + +Lemma bblock_deps_Some_correct2 p m0 m1: + (forall x, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x)) + -> res_eq (Some m1) (run p m0). +Proof. + intros; eapply tree_eval_Some_correct2; eauto. + intros; autorewrite with dict_rw; simpl; eauto. +Qed. + + +Theorem bblock_deps_equiv p1 p2: + (forall x, deps_get (bblock_deps p1) x = deps_get (bblock_deps p2) x) + -> bblock_equiv p1 p2. +Proof. + intros H m2. + remember (run p1 m2) as om1. + destruct om1; simpl. + + apply bblock_deps_Some_correct2. + intros; rewrite <- H. + apply bblock_deps_Some_correct1; auto. + + rewrite bblock_deps_None_correct. + assert (X: run p1 m2 = None); auto. + rewrite bblock_deps_None_correct in X. + destruct X as [x Hx]. + rewrite H in Hx. + eauto. +Qed. + +End DepTree. + +Require Import PArith. +Require Import FMapPositive. + +Module PosDict <: ResourceDictionary 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 new file mode 100644 index 00000000..65f12b8e --- /dev/null +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -0,0 +1,847 @@ +(** 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 ResourceDictionary. + +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 hTerase (t1 t2: hashV tree) (debug: option pstring): ?? hashV tree := + DO hc <~ hash 3;; + hC_tree {| pre_data:=Terase (data t1) (data t2); + hcodes:=[hc;hid t1; hid t2]; debug_info := debug |}. + +Lemma hTerase_correct t1 t2 dbg: + WHEN hTerase t1 t2 dbg ~> t THEN (data t)=(Terase (data t1) (data t2)). +Proof. + wlp_simplify. +Qed. +Global Opaque hTerase. +Hint Resolve hTerase_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 ! *) + + +Definition hdeps:= Dict.t (hashV tree). + +(* pseudo deps_get *) +Definition pdeps_get (d:hdeps) 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. + +Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree := + match e with + | Name 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 e od1 od2: + (forall x, pdeps_get od1 x = deps_get od2 x) -> + forall d1 d2 dbg, + (forall x, pdeps_get d1 x = deps_get d2 x) -> + WHEN hexp_tree e d1 od1 dbg ~> t THEN data t = exp_tree e d2 od2. +Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d1 d2, + (forall x, pdeps_get d1 x = deps_get d2 x) -> + WHEN hlist_exp_tree le d1 od1 ~> lt THEN data lt = list_exp_tree le d2 od2); simpl; wlp_simplify; congruence. +Qed. +Global Opaque hexp_tree. + +Lemma hexp_tree_correct e d1 od1 dbg: + WHEN hexp_tree e d1 od1 dbg ~> t THEN forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> (forall x, pdeps_get d1 x = deps_get d2 x) -> data t = exp_tree e d2 od2. +Proof. + intros t H od2 d2 H1 H2; apply (hexp_tree_correct_x e od1 od2 H1 d1 d2 dbg H2 t H). +Qed. +Hint Resolve hexp_tree_correct: wlp. + +Variable debug_assign: R.t -> ?? option pstring. + +Fixpoint hmacro_deps (i: macro) (d od: hdeps): ?? hdeps := + match i with + | nil => RET d + | (x, e)::i' => + DO dbg <~ debug_assign x;; + DO t0 <~ hdeps_get d x None;; + DO v' <~ (if failsafe (data t0) + then + hexp_tree e d od dbg + else + DO t1 <~ hexp_tree e d od None;; + hTerase t1 t0 dbg);; + hmacro_deps i' (Dict.set d x v') od + end. + +Lemma pset_spec_eq d x t: + pdeps_get (Dict.set d x t) x = (data t). +Proof. + unfold pdeps_get; rewrite Dict.set_spec_eq; simpl; auto. +Qed. + +Lemma pset_spec_diff d x y t: + x <> y -> pdeps_get (Dict.set d x t) y = pdeps_get d y. +Proof. + unfold pdeps_get; intros; rewrite Dict.set_spec_diff; simpl; auto. +Qed. + +Lemma pempty_spec x: pdeps_get Dict.empty x = Tname x. +Proof. + unfold pdeps_get; rewrite Dict.empty_spec; simpl; auto. +Qed. + +Hint Rewrite pset_spec_eq pempty_spec: dict_rw. + + +Lemma hmacro_deps_correct i: forall d1 od1, + WHEN hmacro_deps i d1 od1 ~> d1' THEN + forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> + (forall x, pdeps_get d1 x = deps_get d2 x) -> + forall x, pdeps_get d1' x = deps_get (macro_deps i d2 od2) x. +Proof. + induction i; simpl; wlp_simplify. + + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). + - erewrite H0, H2; simpl; eauto. clear exta2 Hexta2 H2; auto. + intros x0; destruct (R.eq_dec a0 x0). + * subst; autorewrite with dict_rw. erewrite H1; eauto. + * rewrite set_spec_diff, pset_spec_diff; auto. + - rewrite H, H4; auto. + + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). + - erewrite H0, H3; simpl; eauto. clear exta3 Hexta3 H3; auto. + intros x0; destruct (R.eq_dec a0 x0). + * subst; autorewrite with dict_rw. rewrite H2. + erewrite H, H1; eauto. congruence. + * rewrite set_spec_diff, pset_spec_diff; auto. + - rewrite H, H5; auto. +Qed. +Global Opaque hmacro_deps. +Hint Resolve hmacro_deps_correct: wlp. + +(* logging info: we log the number of macro-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' <~ hmacro_deps i d d;; + hbblock_deps_rec p' d' + end. + +Lemma hbblock_deps_rec_correct p: forall d1, + WHEN hbblock_deps_rec p d1 ~> d1' THEN + forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec p d2) x. +Proof. + induction p; simpl; wlp_simplify. +Qed. +Global Opaque hbblock_deps_rec. +Hint Resolve hbblock_deps_rec_correct: wlp. + + +Definition hbblock_deps: bblock -> ?? hdeps + := fun p => hbblock_deps_rec p Dict.empty. + +Lemma hbblock_deps_correct p: + WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps p) x. +Proof. + unfold bblock_deps; wlp_simplify. erewrite H; eauto. + intros; autorewrite with dict_rw; auto. +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 + | Terase t1a t2a, Terase t1b t2b => + DO b <~ phys_eq t1a t1b ;; + if b + then phys_eq t2a t2b + 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: + (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. + + +(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) + +Section Prog_Eq_Gen. + +Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 macros *) +Variable dbg2: R.t -> ?? option pstring. (* log of p2 macros *) +Variable log1: unit -> ?? unit. (* log of p1 macros *) +Variable log2: unit -> ?? unit. (* log of p2 macros *) + + + +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. + +Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := + 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 RET true + else ( + print_error_end d1 d2 ;; + RET false + ) + CATCH_FAIL s, _ => + print_error s;; + RET false + ENSURE (fun b => b=true -> bblock_equiv p1 p2));; + RET (`r). +Obligation 1. + destruct hco_tree_correct as [X1 X2], hco_list_correct as [Y1 Y2]. + constructor 1; wlp_simplify; try congruence. + apply bblock_deps_equiv; auto. + intros; rewrite <- H, <- H0. + apply pdeps_get_intro. auto. +Qed. + +Theorem g_bblock_eq_test_correct p1 p2: + WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Proof. + wlp_simplify. + destruct exta; simpl in * |- *; auto. +Qed. +Global Opaque g_bblock_eq_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_eq_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 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). + + +Program Definition bblock_eq_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_eq_test no_dbg no_dbg skip (log_insert log) hco_tree _ hco_list _ print_error_end (print_error log) 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_eq_test_correct. + +Theorem bblock_eq_test_correct p1 p2: + WHEN bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque bblock_eq_test. + + + +(** This is only to print info on each bblock_eq_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)) + | (Terase _ _), [ _ ; t1; t2 ] => + DO st1 <~ string_of_hashcode t1 ;; + DO st2 <~ string_of_hashcode t2 ;; + println((tree_id st1) +; " erases " +; (tree_id st2)) + | _, _ => 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 +; ")") + | Terase t _, [ _ ; tid; _ ] => + DO pt <~ get_htree tid ;; + string_of_tree t pt + | _, _ => 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 + | _ => FAILWITH "No witness info" + 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_eq_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_eq_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) + 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_eq_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) + p2 p1;; + if result2 + then ( + println (msg_prefix +; " OOops - symmetry violation in bblock_eq_test => this is a bug of bblock_eq_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_eq_test_correct p1 p2: + WHEN verb_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque verb_bblock_eq_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. + +(* 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. + + +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 new file mode 100644 index 00000000..55931e0f --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -0,0 +1,82 @@ +(** Impure Config for UNTRUSTED backend !!! *) + +Require Import ImpMonads. +Require Extraction. +(** Pure computations (used for extraction !) + +We keep module [Impure] opaque in order to check that Coq proof do not depend on +the implementation of [Impure]. + +*) + +Module Type ImpureView. + + Include MayReturnMonad. + +(* WARNING: THIS IS REALLY UNSAFE TO DECOMMENT THE "UnsafeImpure" module ! + + unsafe_coerce coerces an impure computation into a pure one ! + +*) + +(* + Module UnsafeImpure. + + Parameter unsafe_coerce: forall {A}, t A -> A. + + Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. + + End UnsafeImpure. +*) + +End ImpureView. + + +Module Impure: ImpureView. + + Include IdentityMonad. + + Module UnsafeImpure. + + Definition unsafe_coerce {A} (x:t A) := x. + + Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=x -> mayRet k x. + Proof. + unfold unsafe_coerce, mayRet; auto. + Qed. + + End UnsafeImpure. + +End Impure. + + +(** Comment the above code and decomment this to test that coq proofs still work with an impure monad ! + +- this should fail only on extraction or if unsafe_coerce is used ! + +*) +(* +Module Impure: MayReturnMonad := PowerSetMonad. +*) + +Export Impure. + +Extraction Inline ret mk_annot. + + +(* WARNING. The following directive is unsound. + + Extraction Inline bind + +For example, it may lead to extract the following code as "true" (instead of an error raising code) + failwith "foo";;true + +*) + +Extract Inlined Constant bind => "(|>)". + + +Extract Constant t "" => "". (* This weird directive extracts [t] as "'a" instead of "'a t" *) +Extraction Inline t. + +Global Opaque t. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v new file mode 100644 index 00000000..6eb0c5af --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -0,0 +1,187 @@ +(** Impure monad for interface with impure code + +*) + +Require Export Program. +Require Export ImpConfig. + +(* Theory: bind + embed => dbind + +Program Definition dbind {A B} (k1: t A) (k2: forall (a:A), (mayRet k1 a) -> t B) : t B + := bind (mk_annot k1) (fun a => k2 a _). + +Lemma mayRet_dbind: forall (A B:Type) k1 k2 (b:B), + mayRet (dbind k1 k2) b -> exists a:A, exists H: (mayRet k1 a), mayRet (k2 a H) b. +Proof. + intros A B k1 k2 b H; decompose [ex and] (mayRet_bind _ _ _ _ _ H). + eapply ex_intro. + eapply ex_intro. + eauto. +Qed. + +*) + +Definition wlp {A:Type} (k: t A) (P: A -> Prop): Prop + := forall a, mayRet k a -> P a. + +(* Notations *) + +(* Print Grammar constr. *) + +Module Notations. + + Bind Scope impure_scope with t. + Delimit Scope impure_scope with impure. + + Notation "?? A" := (t A) (at level 0, A at level 95): impure_scope. + + Notation "k '~~>' a" := (mayRet k a) (at level 75, no associativity): impure_scope. + + Notation "'RET' a" := (ret a) (at level 0): impure_scope. + + Notation "'DO' x '<~' k1 ';;' k2" := (bind k1 (fun x => k2)) + (at level 55, k1 at level 53, x at level 99, right associativity): impure_scope. + + Notation "k1 ';;' k2" := (bind k1 (fun _ => k2)) + (at level 55, right associativity): impure_scope. + + Notation "'WHEN' k '~>' a 'THEN' R" := (wlp k (fun a => R)) + (at level 73, R at level 100, right associativity): impure_scope. + + Notation "'ASSERT' P" := (ret (A:=P) _) (at level 0, only parsing): impure_scope. + +End Notations. + +Import Notations. +Local Open Scope impure. + +Goal ((?? list nat * ??nat -> nat) = ((?? ((list nat) * ?? nat) -> nat)))%type. +Proof. + apply refl_equal. +Qed. + + +(* wlp lemmas for tactics *) + +Lemma wlp_unfold A (k:??A)(P: A -> Prop): + (forall a, k ~~> a -> P a) + -> wlp k P. +Proof. + auto. +Qed. + +Lemma wlp_monotone A (k:?? A) (P1 P2: A -> Prop): + wlp k P1 + -> (forall a, k ~~> a -> P1 a -> P2 a) + -> wlp k P2. +Proof. + unfold wlp; eauto. +Qed. + +Lemma wlp_forall A B (k:?? A) (P: B -> A -> Prop): + (forall x, wlp k (P x)) + -> wlp k (fun a => forall x, P x a). +Proof. + unfold wlp; auto. +Qed. + +Lemma wlp_ret A (P: A -> Prop) a: + P a -> wlp (ret a) P. +Proof. + unfold wlp. + intros H b H0. + rewrite <- (mayRet_ret _ a b H0). + auto. +Qed. + +Lemma wlp_bind A B (k1:??A) (k2: A -> ??B) (P: B -> Prop): + wlp k1 (fun a => wlp (k2 a) P) -> wlp (bind k1 k2) P. +Proof. + unfold wlp. + intros H a H0. + case (mayRet_bind _ _ _ _ _ H0); clear H0. + intuition eauto. +Qed. + +Lemma wlp_ifbool A (cond: bool) (k1 k2: ?? A) (P: A -> Prop): + (cond=true -> wlp k1 P) -> (cond=false -> wlp k2 P) -> wlp (if cond then k1 else k2) P. +Proof. + destruct cond; auto. +Qed. + +Lemma wlp_letprod (A B C: Type) (p: A*B) (k: A -> B -> ??C) (P: C -> Prop): + (wlp (k (fst p) (snd p)) P) + -> (wlp (let (x,y):=p in (k x y)) P). +Proof. + destruct p; simpl; auto. +Qed. + +Lemma wlp_sum (A B C: Type) (x: A+B) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): + (forall a, x=inl a -> wlp (k1 a) P) -> + (forall b, x=inr b -> wlp (k2 b) P) -> + (wlp (match x with inl a => k1 a | inr b => k2 b end) P). +Proof. + destruct x; simpl; auto. +Qed. + +Lemma wlp_sumbool (A B:Prop) (C: Type) (x: {A}+{B}) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): + (forall a, x=left a -> wlp (k1 a) P) -> + (forall b, x=right b -> wlp (k2 b) P) -> + (wlp (match x with left a => k1 a | right b => k2 b end) P). +Proof. + destruct x; simpl; auto. +Qed. + +(* Tactics + +MAIN tactics: + - xtsimplify "base": simplification using from hints in "base" database (in particular "wlp" lemmas). + - xtstep "base": only one step of simplification. + +For good performance, it is recommanded to have several databases. + +*) + +Ltac introcomp := + let a:= fresh "exta" in + let H:= fresh "Hexta" in + intros a H. + +(* decompose the current wlp goal using "introduction" rules *) +Ltac wlp_decompose := + apply wlp_ret + || apply wlp_bind + || apply wlp_ifbool + || apply wlp_letprod + || apply wlp_sum + || apply wlp_sumbool + . + +(* this tactic simplifies the current "wlp" goal using any hint found via tactic "hint". *) +Ltac apply_wlp_hint hint := + eapply wlp_monotone; + [ hint; fail | idtac ] ; + simpl; introcomp. + +(* one step of wlp_xsimplify +*) +Ltac wlp_step hint := + match goal with + | |- (wlp _ _) => + wlp_decompose + || apply_wlp_hint hint + || (apply wlp_unfold; introcomp) + end. + +(* main general tactic +WARNING: for the good behavior of "wlp_xsimplify", "hint" must at least perform a "eauto". + +Example of use: + wlp_xsimplify (intuition eauto with base). +*) +Ltac wlp_xsimplify hint := + repeat (intros; subst; wlp_step hint; simpl; (tauto || hint)). + +Create HintDb wlp discriminated. + +Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). \ No newline at end of file diff --git a/mppa_k1c/abstractbb/Impure/ImpExtern.v b/mppa_k1c/abstractbb/Impure/ImpExtern.v new file mode 100644 index 00000000..8fb3cf3b --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpExtern.v @@ -0,0 +1,7 @@ +(** Exporting Extern functions +*) + +Require Export ImpPrelude. +Require Export ImpIO. +Require Export ImpLoops. +Require Export ImpHCons. diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v new file mode 100644 index 00000000..307eb163 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -0,0 +1,48 @@ +Require Export ImpIO. + +Import Notations. +Local Open Scope impure. + +(********************************) +(* (Weak) HConsing *) + +Axiom string_of_hashcode: hashcode -> ?? caml_string. +Extract Constant string_of_hashcode => "string_of_int". + +Axiom hash: forall {A}, A -> ?? hashcode. +Extract Constant hash => "Hashtbl.hash". + +Axiom xhCons: forall {A}, ((A -> A -> ?? bool) * (pre_hashV A -> ?? hashV A)) -> ?? hashConsing A. +Extract Constant xhCons => "ImpHConsOracles.xhCons". + +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) ;; + 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; + |}. + +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')). +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')). diff --git a/mppa_k1c/abstractbb/Impure/ImpIO.v b/mppa_k1c/abstractbb/Impure/ImpIO.v new file mode 100644 index 00000000..6c02c395 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpIO.v @@ -0,0 +1,159 @@ +(** Extension of Coq language with some IO and exception-handling operators. + +TODO: integration with http://coq.io/ ? + +*) + +Require Export ImpPrelude. + +Import Notations. +Local Open Scope impure. + +(** Printing functions *) + +Axiom print: pstring -> ?? unit. +Extract Constant print => "ImpIOOracles.print". + +Axiom println: pstring -> ?? unit. +Extract Constant println => "ImpIOOracles.println". + +Axiom read_line: unit -> ?? pstring. +Extract Constant read_line => "ImpIOOracles.read_line". + +Require Import ZArith. +Axiom string_of_Z: Z -> ?? pstring. +Extract Constant string_of_Z => "ImpIOOracles.string_of_Z". + +(** timer *) + +Axiom timer: forall {A B}, (A -> ?? B)*A -> ?? B. +Extract Constant timer => "ImpIOOracles.timer". + +(** Exception Handling *) + +Axiom exit_observer: Type. +Extract Constant exit_observer => "((unit -> unit) ref)". + +Axiom new_exit_observer: (unit -> ??unit) -> ??exit_observer. +Extract Constant new_exit_observer => "ImpIOOracles.new_exit_observer". + +Axiom set_exit_observer: exit_observer * (unit -> ??unit) -> ??unit. +Extract Constant set_exit_observer => "ImpIOOracles.set_exit_observer". + +Axiom exn: Type. +Extract Inlined Constant exn => "exn". + +Axiom raise: forall {A}, exn -> ?? A. +Extract Constant raise => "raise". + +Axiom exn2string: exn -> ?? pstring. +Extract Constant exn2string => "ImpIOOracles.exn2string". + +Axiom fail: forall {A}, pstring -> ?? A. +Extract Constant fail => "ImpIOOracles.fail". + +Axiom try_with_fail: forall {A}, (unit -> ?? A) * (pstring -> exn -> ??A) -> ??A. +Extract Constant try_with_fail => "ImpIOOracles.try_with_fail". + +Axiom try_with_any: forall {A}, (unit -> ?? A) * (exn -> ??A) -> ??A. +Extract Constant try_with_any => "ImpIOOracles.try_with_any". + +Notation "'RAISE' e" := (DO r <~ raise (A:=False) e ;; RET (match r with end)) (at level 0): impure_scope. +Notation "'FAILWITH' msg" := (DO r <~ fail (A:=False) msg ;; RET (match r with end)) (at level 0): impure_scope. + +Definition _FAILWITH {A:Type} msg: ?? A := FAILWITH msg. + +Example _FAILWITH_correct A msg (P: A -> Prop): + WHEN _FAILWITH msg ~> r THEN P r. +Proof. + wlp_simplify. +Qed. + +Notation "'TRY' k1 'WITH_FAIL' s ',' e '=>' k2" := (try_with_fail (fun _ => k1, fun s e => k2)) + (at level 55, k1 at level 53, right associativity): impure_scope. + +Notation "'TRY' k1 'WITH_ANY' e '=>' k2" := (try_with_any (fun _ => k1, fun e => k2)) + (at level 55, k1 at level 53, right associativity): impure_scope. + + +Program Definition assert_b (b: bool) (msg: pstring): ?? b=true := + match b with + | true => RET _ + | false => FAILWITH msg + end. + +Lemma assert_wlp_true msg b: WHEN assert_b b msg ~> _ THEN b=true. +Proof. + wlp_simplify. +Qed. + +Lemma assert_false_wlp msg (P: Prop): WHEN assert_b false msg ~> _ THEN P. +Proof. + simpl; wlp_simplify. +Qed. + +Program Definition try_catch_fail_ensure {A} (k1: unit -> ?? A) (k2: pstring -> exn -> ??A) (P: A -> Prop | wlp (k1 tt) P /\ (forall s e, wlp (k2 s e) P)): ?? { r | P r } + := TRY + DO r <~ mk_annot (k1 tt);; + RET (exist P r _) + WITH_FAIL s, e => + DO r <~ mk_annot (k2 s e);; + RET (exist P r _). +Obligation 2. + unfold wlp in * |- *; eauto. +Qed. + +Notation "'TRY' k1 'CATCH_FAIL' s ',' e '=>' k2 'ENSURE' P" := (try_catch_fail_ensure (fun _ => k1) (fun s e => k2) (exist _ P _)) + (at level 55, k1 at level 53, right associativity): impure_scope. + +Definition is_try_post {A} (P: A -> Prop) k1 k2 : Prop := + wlp (k1 ()) P /\ forall (e:exn), wlp (k2 e) P. + +Program Definition try_catch_ensure {A} k1 k2 (P:A->Prop|is_try_post P k1 k2): ?? { r | P r } + := TRY + DO r <~ mk_annot (k1 ());; + RET (exist P r _) + WITH_ANY e => + DO r <~ mk_annot (k2 e);; + RET (exist P r _). +Obligation 1. + unfold is_try_post, wlp in * |- *; intuition eauto. +Qed. +Obligation 2. + unfold is_try_post, wlp in * |- *; intuition eauto. +Qed. + +Notation "'TRY' k1 'CATCH' e '=>' k2 'ENSURE' P" := (try_catch_ensure (fun _ => k1) (fun e => k2) (exist _ P _)) + (at level 55, k1 at level 53, right associativity): impure_scope. + + +Program Example tryex {A} (x y:A) := + TRY (RET x) + CATCH _ => (RET y) + ENSURE (fun r => r = x \/ r = y). +Obligation 1. + split; wlp_simplify. +Qed. + +Program Example tryex_test {A} (x y:A): + WHEN tryex x y ~> r THEN `r <> x -> `r = y. +Proof. + wlp_simplify. destruct exta as [r [X|X]]; intuition. +Qed. + + +Program Example try_branch1 {A} (x:A): ?? { r | r = x} := + TRY (RET x) + CATCH e => (FAILWITH "!") + ENSURE _. +Obligation 1. + split; wlp_simplify. +Qed. + +Program Example try_branch2 {A} (x:A): ?? { r | r = x} := + TRY (FAILWITH "!") + CATCH e => (RET x) + ENSURE _. +Obligation 1. + split; wlp_simplify. +Qed. diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v new file mode 100644 index 00000000..9e11195e --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpLoops.v @@ -0,0 +1,121 @@ +(** Extension of Coq language with generic loops. *) + +Require Export ImpIO. + +Import Notations. +Local Open Scope impure. + + +(** While-loop iterations *) + +Axiom loop: forall {A B}, A * (A -> ?? (A+B)) -> ?? B. +Extract Constant loop => "ImpLoopOracles.loop". + +(** A while loop *) + +Record while_loop_invariant {S} (cond: S -> bool) (body: S -> ?? S) (s0: S) (I: S -> Prop): Prop := + { while_init: I s0; + while_preserv s: I s -> cond s = true -> WHEN (body s) ~> s' THEN I s' + }. +Arguments while_init [S cond body s0 I]. +Arguments while_preserv [S cond body s0 I]. + +Program Definition while {S} cond body s0 (I: S -> Prop | while_loop_invariant cond body s0 I): ?? {s | I s /\ cond s = false} + := loop (A:={s | I s}) + (s0, + fun s => + match (cond s) with + | true => + DO s' <~ mk_annot (body s) ;; + RET (inl (A:={s | I s }) s') + | false => + RET (inr (B:={s | I s /\ cond s = false}) s) + end). +Obligation 1. + destruct H; auto. +Qed. +Obligation 2. + eapply (while_preserv H1); eauto. +Qed. +Extraction Inline while. + +(** A loop until None (useful to demonstrate a UNSAT property) *) + +Program Definition loop_until_None {S} (I: S -> Prop) (body: S -> ?? (option S)) + (H:forall s, I s -> WHEN (body s) ~> s' THEN match s' with Some s1 => I s1 | None => False end) (s0:S): ?? ~(I s0) + := loop (A:={s | I s0 -> I s}) + (s0, + fun s => + DO s' <~ mk_annot (body s) ;; + match s' with + | Some s1 => RET (inl (A:={s | I s0 -> I s }) s1) + | None => RET (inr (B:=~(I s0)) _) + end). +Obligation 2. + refine (H s _ _ H1). auto. +Qed. +Obligation 3. + intros X; refine (H s _ _ H0). auto. +Qed. +Extraction Inline loop_until_None. + + +(*********************************************) +(* A generic fixpoint from an equality test *) + +Record answ {A B: Type} {R: A -> B -> Prop} := { + input: A ; + output: B ; + correct: R input output +}. +Arguments answ {A B}. + +Definition msg: pstring := "wapply fails". + +Definition beq_correct {A} (beq: A -> A -> ?? bool) := + forall x y, WHEN beq x y ~> b THEN b=true -> x=y. + +Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ?? answ R) (x:A): ?? B := + DO a <~ k x;; + DO b <~ beq x (input 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): + beq_correct beq + -> WHEN wapply beq k x ~> y THEN R x y. +Proof. + unfold beq_correct; wlp_simplify. + destruct exta; simpl; auto. +Qed. +Local Hint Resolve wapply_correct: wlp. +Global Opaque wapply. + +Axiom xrec_set_option: recMode -> ?? unit. +Extract Constant xrec_set_option => "ImpLoopOracles.xrec_set_option". + +(* TODO: generalizaton to get beq (and a Hash function ?) in parameters ? *) +Axiom xrec: forall {A B}, ((A -> ?? B) -> A -> ?? B) -> ?? (A -> ?? B). +Extract Constant xrec => "ImpLoopOracles.xrec". + +Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop) := + forall f x, WHEN recF f x ~> z THEN (forall x', WHEN f x' ~> y THEN R x' y) -> R x z. + + +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 (wapply beq f). +Obligation 1. + eapply H1; eauto. clear H H1. + wlp_simplify. +Qed. + +Lemma rec_correct A B beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): + WHEN rec beq recF R H1 H2 ~> f THEN forall x, WHEN f x ~> y THEN R x y. +Proof. + wlp_simplify. +Qed. +Hint Resolve rec_correct: wlp. +Global Opaque rec. diff --git a/mppa_k1c/abstractbb/Impure/ImpMonads.v b/mppa_k1c/abstractbb/Impure/ImpMonads.v new file mode 100644 index 00000000..f01a2755 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpMonads.v @@ -0,0 +1,148 @@ +(** Impure monad for interface with impure code +*) + + +Require Import Program. + + +Module Type MayReturnMonad. + + Axiom t: Type -> Type. + + Axiom mayRet: forall {A:Type}, t A -> A -> Prop. + + Axiom ret: forall {A}, A -> t A. + + Axiom bind: forall {A B}, (t A) -> (A -> t B) -> t B. + + Axiom mk_annot: forall {A} (k: t A), t { a: A | mayRet k a }. + + Axiom mayRet_ret: forall A (a b:A), + mayRet (ret a) b -> a=b. + + Axiom mayRet_bind: forall A B k1 k2 (b:B), + mayRet (bind k1 k2) b -> exists a:A, mayRet k1 a /\ mayRet (k2 a) b. + +End MayReturnMonad. + + + +(** Model of impure computation as predicate *) +Module PowerSetMonad<: MayReturnMonad. + + Definition t (A:Type) := A -> Prop. + + Definition mayRet {A:Type} (k: t A) a: Prop := k a. + + Definition ret {A:Type} (a:A) := eq a. + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := + fun b => exists a, k1 a /\ k2 a b. + + Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := fun _ => True. + + Lemma mayRet_ret A (a b:A): mayRet (ret a) b -> a=b. + Proof. + unfold mayRet, ret. firstorder. + Qed. + + Lemma mayRet_bind A B k1 k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + unfold mayRet, bind. + firstorder. + Qed. + +End PowerSetMonad. + + +(** The identity interpretation *) +Module IdentityMonad<: MayReturnMonad. + + Definition t (A:Type) := A. + + (* may-return semantics of computations *) + Definition mayRet {A:Type} (a b:A): Prop := a=b. + + Definition ret {A:Type} (a:A) := a. + + Definition bind {A B:Type} (k1: A) (k2: A -> B) := k2 k1. + + Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } + := exist _ k (eq_refl k) . + + Lemma mayRet_ret (A:Type) (a b:A): mayRet (ret a) b -> a=b. + Proof. + intuition. + Qed. + + Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + firstorder. + Qed. + +End IdentityMonad. + + +(** Model of impure computation as state-transformers *) +Module StateMonad<: MayReturnMonad. + + Parameter St: Type. (* A global state *) + + Definition t (A:Type) := St -> A * St. + + Definition mayRet {A:Type} (k: t A) a: Prop := + exists s, fst (k s)=a. + + Definition ret {A:Type} (a:A) := fun (s:St) => (a,s). + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := + fun s0 => let r := k1 s0 in k2 (fst r) (snd r). + + Program Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := + fun s0 => let r := k s0 in (exist _ (fst r) _, snd r). + Obligation 1. + unfold mayRet; eauto. + Qed. + + Lemma mayRet_ret {A:Type} (a b:A): mayRet (ret a) b -> a=b. + Proof. + unfold mayRet, ret. firstorder. + Qed. + + Lemma mayRet_bind {A B:Type} k1 k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + unfold mayRet, bind. firstorder eauto. + Qed. + +End StateMonad. + +(** The deferred interpretation *) +Module DeferredMonad<: MayReturnMonad. + + Definition t (A:Type) := unit -> A. + + (* may-return semantics of computations *) + Definition mayRet {A:Type} (a: t A) (b:A): Prop := a tt=b. + + Definition ret {A:Type} (a:A) : t A := fun _ => a. + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) : t B := fun _ => k2 (k1 tt) tt. + + Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } + := fun _ => exist _ (k tt) (eq_refl (k tt)). + + Lemma mayRet_ret (A:Type) (a b: A): mayRet (ret a) b -> a=b. + Proof. + intuition. + Qed. + + Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + firstorder. + Qed. + +End DeferredMonad. diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v new file mode 100644 index 00000000..cebc7a72 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -0,0 +1,163 @@ +Require Export String. +Require Export List. +Require Extraction. +Require Import Ascii. +Require Import BinNums. +Require Export ImpCore. + +Axiom caml_string: Type. +Extract Constant caml_string => "string". + +(** New line *) +Definition nl: string := String (ascii_of_pos 10%positive) EmptyString. + +Inductive pstring: Type := + | Str: string -> pstring + | CamlStr: caml_string -> pstring + | Concat: pstring -> pstring -> pstring. + +Coercion Str: string >-> pstring. +Bind Scope string_scope with pstring. + +Notation "x +; y" := (Concat x y) + (at level 65, left associativity): string_scope. + +(** Coq references *) + +Import Notations. +Local Open Scope impure. + +Record cref {A} := { + set: A -> ?? unit; + get: unit -> ?? A +}. +Arguments cref: clear implicits. + +Axiom make_cref: forall {A}, A -> ?? cref A. +Extract Constant make_cref => "(fun x -> let r = ref x in { set = (fun y -> r:=y); get = (fun () -> !r) })". + + +(** Data-structure for a logger *) + +Record logger {A:Type} := { + log_insert: A -> ?? unit; + log_info: unit -> ?? pstring; +}. +Arguments logger: clear implicits. + +Axiom count_logger: unit -> ?? logger unit. +Extract Constant count_logger => "(fun () -> let count = ref 0 in { log_insert = (fun () -> count := !count + 1); log_info = (fun () -> (CamlStr (string_of_int !count))) })". + + +(** Axioms of Physical equality *) + +Module Type PhysEq. + +Axiom phys_eq: forall {A}, A -> A -> ?? bool. + +Axiom phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. + +End PhysEq. + + + +(* We only check here that above axioms are not trivially inconsistent... + (but this does not prove the correctness of the extraction directive below). + *) +Module PhysEqModel: PhysEq. + +Definition phys_eq {A} (x y: A) := ret false. + +Lemma phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. +Proof. + wlp_simplify. discriminate. +Qed. + +End PhysEqModel. + + + +Export PhysEqModel. + +Extract Constant phys_eq => "(==)". +Hint Resolve phys_eq_correct: wlp. + + + +(** Data-structure for generic hash-consing *) + +Axiom hashcode: Type. +Extract Constant hashcode => "int". + +Record pre_hashV {A: Type} := { + pre_data: A; + hcodes: list hashcode; + debug_info: option pstring; +}. +Arguments pre_hashV: clear implicits. + +Record hashV {A:Type}:= { + data: A; + hid: hashcode +}. +Arguments hashV: clear implicits. + +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 *) +}. +Arguments hashExport: clear implicits. + +Record hashConsing {A:Type}:= { + hC: pre_hashV A -> ?? hashV A; + hC_known: pre_hashV A -> ?? hashV A; (* fails on unknown inputs *) + (**** below: debugging functions ****) + 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. + +(** recMode: this is mainly for Tests ! *) +Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec. + + +(* This a copy-paste from definitions in CompCert/Lib/CoqLib.v *) +Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q. +Proof. auto. Qed. + +Ltac exploit x := + refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _) _) + || refine (modusponens _ _ (x _ _) _) + || refine (modusponens _ _ (x _) _). diff --git a/mppa_k1c/abstractbb/Impure/LICENSE b/mppa_k1c/abstractbb/Impure/LICENSE new file mode 100644 index 00000000..65c5ca88 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/mppa_k1c/abstractbb/Impure/README.md b/mppa_k1c/abstractbb/Impure/README.md new file mode 100644 index 00000000..2b19d14a --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/README.md @@ -0,0 +1,31 @@ +# `Impure`: importing OCaml functions as non-deterministic ones. + +The principle of this library is to encode the type `A -> B` of an +OCaml function as a type `A -> ?? B` in Coq, where `?? B` is the type +of an axiomatized monad that can be interpreted as `B -> Prop`. In +other word, this encoding abstracts an OCaml function as a function +returning a postcondition on its possible results (ie a relation between its +parameter and its result). Side-effects are simply ignored. And +reasoning on such a function is only possible in partial correctness. + +See further explanations and examples on [ImpureDemo](https://github.com/boulme/ImpureDemo). + +## Credits + +[Sylvain Boulmé](mailto:Sylvain.Boulme@univ-grenoble-alpes.fr). + +## Code Overview + +- [ImpMonads](ImpMonads.v) axioms of "impure computations" and some Coq models of these axioms. + +- [ImpConfig](ImpConfig.v) declares the `Impure` monad and defines its extraction. + +- [ImpCore](ImpCore.v) defines notations for the `Impure` monad and a `wlp_simplify` tactic (to reason about `Impure` functions in a Hoare-logic style). + +- [ImpPrelude](ImpPrelude.v) declares the data types exchanged with `Impure` oracles. + +- [ImpIO](ImpIO.v), [ImpLoops](ImpLoops.v), [ImpHCons](ImpHCons.v) declare `Impure` oracles and define operators from these oracles. + [ImpExtern](ImpExtern.v) exports all these impure operators. + +- [ocaml/](ocaml/) subdirectory containing the OCaml implementations of `Impure` oracles. + diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml new file mode 100644 index 00000000..c421ff87 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -0,0 +1,51 @@ +open ImpPrelude + +exception Stop;; + +let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) = + let module MyHashedType = struct + type t = a pre_hashV + let equal x y = hash_eq x.pre_data y.pre_data + let hash x = Hashtbl.hash x.hcodes + end in + let module MyHashtbl = Hashtbl.Make(MyHashedType) in + let pick t = + let res = ref None in + try + MyHashtbl.iter (fun k d -> res:=Some (k,d); raise Stop) t; + None + with + | Stop -> !res + in + 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' + | 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); + next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); + export = fun () -> + match pick t with + | None -> { get_hashV = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } + | Some (k,_) -> + (* the state is fully copied at export ! *) + let logs = ref (List.rev_append (!logs) []) in + let rec step_log i = + match !logs with + | (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; + { + get_hashV = (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 new file mode 100644 index 00000000..e81681df --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -0,0 +1,3 @@ +open ImpPrelude + +val xhCons: (('a -> 'a -> bool) * ('a pre_hashV -> 'a hashV)) -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml new file mode 100644 index 00000000..e5ec8e87 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -0,0 +1,146 @@ +(* Warning + +These oracles assumes the following extraction directives: + "Require Import ExtrOcamlString." + +*) + +open ImpPrelude +open BinNums +open Datatypes + +(* two auxiliary functions, for efficient mapping of "int" to "BinNums.positive" *) +exception Overflow + +let aux_add: ('a, 'b) Hashtbl.t -> 'b Queue.t -> 'a -> 'b -> unit + = fun t q i p -> + if i < 1 then (* protection against wrap around *) + raise Overflow; + Queue.add p q; + Hashtbl.add t i p + +let memo_int2pos: int -> int -> BinNums.positive + = fun n -> + (* init of the Hashtbl *) + let n = max n 1 in + let t = Hashtbl.create n in + let q = Queue.create () in + aux_add t q 1 BinNums.Coq_xH ; + for i = 1 to (n-1)/2 do + let last = Queue.take q in + let ni = 2*i in + aux_add t q ni (BinNums.Coq_xO last); + aux_add t q (ni+1) (BinNums.Coq_xI last) + done; + if n mod 2 = 0 then ( + let last = Queue.take q in + Hashtbl.add t n (BinNums.Coq_xO last) + ); + (* memoized translation of i *) + let rec find i = + try + (* Printf.printf "-> %d\n" i; *) + Hashtbl.find t i + with Not_found -> + (* Printf.printf "<- %d\n" i; *) + if i <= 0 then + invalid_arg "non-positive integer" + else + let p = find (i/2) in + let pi = if i mod 2 = 0 then BinNums.Coq_xO p else BinNums.Coq_xI p in + Hashtbl.add t i pi; + pi + in find;; + + +let string_coq2caml: char list -> string + = fun l -> + let buf = Buffer.create (List.length l) in + List.iter (fun c -> Buffer.add_char buf c) l; + Buffer.contents buf;; + +let new_exit_observer: (unit -> unit) -> (unit -> unit) ref + = fun f -> + let o = ref f in + at_exit (fun () -> !o()); + o;; + +let set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit + = fun (r, f) -> r := f + +let rec print: pstring -> unit + = fun ps -> + match ps with + | Str l -> List.iter print_char l + | CamlStr s -> print_string s + | Concat(ps1,ps2) -> (print ps1; print ps2);; + +let println: pstring -> unit + = fun l -> print l; print_newline() + +let read_line () = + CamlStr (Pervasives.read_line());; + +exception ImpureFail of pstring;; + +let exn2string: exn -> pstring + = fun e -> CamlStr (Printexc.to_string e) + +let fail: pstring -> 'a + = fun s -> raise (ImpureFail s);; + +let try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a + = fun (k1, k2) -> + try + k1() + with + | (ImpureFail s) as e -> k2 s e + +let try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a + = fun (k1, k2) -> + try + k1() + with + | e -> k2 e + +(** MISC **) + +let rec posTr: BinNums.positive -> int += function + | BinNums.Coq_xH -> 1 + | BinNums.Coq_xO p -> (posTr p)*2 + | BinNums.Coq_xI p -> (posTr p)*2+1;; + +let zTr: BinNums.coq_Z -> int += function + | BinNums.Z0 -> 0 + | BinNums.Zpos p -> posTr p + | BinNums.Zneg p -> - (posTr p) + +let ten = BinNums.Zpos (BinNums.Coq_xO (BinNums.Coq_xI (BinNums.Coq_xO BinNums.Coq_xH))) + +let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring += let (q,r) = BinIntDef.Z.pos_div_eucl p ten in + let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in + match q with + | BinNums.Z0 -> acc0 + | BinNums.Zpos p0 -> string_of_pos p0 acc0 + | _ -> assert false + +let string_of_Z_debug: BinNums.coq_Z -> pstring += fun p -> CamlStr (string_of_int (zTr p)) + +let string_of_Z: BinNums.coq_Z -> pstring += function + | BinNums.Z0 -> CamlStr "0" + | BinNums.Zpos p -> string_of_pos p (CamlStr "") + | BinNums.Zneg p -> Concat (CamlStr "-", string_of_pos p (CamlStr "")) + +let timer ((f:'a -> 'b), (x:'a)) : 'b = + Gc.compact(); + let itime = (Unix.times()).Unix.tms_utime in + let r = f x in + let rt = (Unix.times()).Unix.tms_utime -. itime in + Printf.printf "time = %f\n" rt; + r + diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli new file mode 100644 index 00000000..29db881b --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli @@ -0,0 +1,34 @@ +open ImpPrelude +open Datatypes + + +(* +Memoized version of translation from int -> BinNums.positive. +The first arg is an indicative bound on the max int translated: +it pre-computes all positives lower or equal to this bound. +*) +val memo_int2pos: int -> int -> BinNums.positive + +val read_line: unit -> pstring + +val print: pstring -> unit + +val println: pstring -> unit + +val string_of_Z: BinNums.coq_Z -> pstring + +val timer : (('a -> 'b ) * 'a) -> 'b + +val new_exit_observer: (unit -> unit) -> (unit -> unit) ref + +val set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit + +val exn2string: exn -> pstring + +val fail: pstring -> 'a + +exception ImpureFail of pstring;; + +val try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a + +val try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml new file mode 100644 index 00000000..cb7625e5 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml @@ -0,0 +1,78 @@ +open ImpPrelude +open Datatypes + +(** GENERIC ITERATIVE LOOP **) + +(* a simple version of loop *) +let simple_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + = fun (a0, f) -> + let rec iter: 'a -> 'b + = fun a -> + match f a with + | Coq_inl a' -> iter a' + | Coq_inr b -> b + in + iter a0;; + +(* loop from while *) +let while_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + = fun (a0, f) -> + let s = ref (f a0) in + while (match !s with Coq_inl _ -> true | _ -> false) do + match !s with + | Coq_inl a -> s:=f a + | _ -> assert false + done; + match !s with + | Coq_inr b -> b + | _ -> assert false;; + +let loop = simple_loop + + +(** GENERIC FIXPOINTS **) + +let std_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let rec f x = recf f x in + f + +let memo_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let memo = Hashtbl.create 10 in + let rec f x = + try + Hashtbl.find memo x + with + Not_found -> + let r = recf f x in + Hashtbl.replace memo x r; + r + in f + +let bare_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let fix = ref (fun x -> failwith "init") in + fix := (fun x -> recf !fix x); + !fix;; + +let buggy_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let memo = ref None in + let rec f x = + match !memo with + | Some y -> y + | None -> + let r = recf f x in + memo := Some r; + r + in f + +let xrec_mode = ref MemoRec + +let xrec_set_option : recMode -> unit += fun m -> xrec_mode := m + +let xrec : (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) + = fun recf -> + match !xrec_mode with + | StdRec -> std_rec recf + | MemoRec -> memo_rec recf + | BareRec -> bare_rec recf + | BuggyRec -> buggy_rec recf diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli new file mode 100644 index 00000000..194696a1 --- /dev/null +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli @@ -0,0 +1,8 @@ +open ImpPrelude +open Datatypes + +val loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + +val xrec_set_option: recMode -> unit + +val xrec: (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v new file mode 100644 index 00000000..6bfd8770 --- /dev/null +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -0,0 +1,743 @@ +(** Parallel Semantics of Abstract Basic Blocks and parallelizability test.s +*) + +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. + +Require Import List. +Import ListNotations. +Local Open Scope list_scope. + +Require Import Sorting.Permutation. +Require Import Bool. +Local Open Scope lazy_bool_scope. + + +Module ParallelSemantics (L: SeqLanguage). + +Export L. +Local Open Scope list. + +(* parallel run of a macro *) +Fixpoint macro_prun (i: macro) (m tmp old: mem): option mem := + match i with + | nil => Some m + | (x, e)::i' => + match exp_eval e tmp old with + | Some v' => macro_prun i' (assign m x v') (assign tmp x v') old + | None => None + end + end. + +(* [macro_prun] is generalization of [macro_run] *) +Lemma macro_run_prun i: forall m old, + macro_run i m old = macro_prun i m m old. +Proof. + induction i as [|[y e] i']; simpl; auto. + intros m old; destruct (exp_eval e m old); simpl; auto. +Qed. + + +(* parallel run of a bblock -- with in-order writes *) +Fixpoint prun_iw (p: bblock) m old: option mem := + match p with + | nil => Some m + | i::p' => + match macro_prun i m old old with + | Some m1 => prun_iw p' m1 old + | None => None + end + end. + +(* non-deterministic parallel run, due to arbitrary writes order *) +Definition prun (p: bblock) m (om: option mem) := exists p', res_eq om (prun_iw p' m m) /\ Permutation p p'. + + +(* a few lemma on equality *) + +Lemma macro_prun_equiv i old: forall m1 m2 tmp, + (forall x, m1 x = m2 x) -> + res_eq (macro_prun i m1 tmp old) (macro_prun i m2 tmp old). +Proof. + induction i as [|[x e] i']; simpl; eauto. + intros m1 m2 tmp H; destruct (exp_eval e tmp old); simpl; auto. + eapply IHi'; unfold assign. intros; destruct (R.eq_dec x x0); auto. +Qed. + +Lemma prun_iw_equiv p: forall m1 m2 old, + (forall x, m1 x = m2 x) -> + res_eq (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + induction p as [|i p']; simpl; eauto. + - intros m1 m2 old H. + generalize (macro_prun_equiv i old m1 m2 old H); + destruct (macro_prun i m1 old old); simpl. + + intros (m3 & H3 & H4); rewrite H3; simpl; eauto. + + intros H1; rewrite H1; simpl; auto. +Qed. + +End ParallelSemantics. + + + + + +Fixpoint notIn {A} (x: A) (l:list A): Prop := + match l with + | nil => True + | a::l' => x <> a /\ notIn x l' + end. + +Lemma notIn_iff A (x:A) l: (~List.In x l) <-> notIn x l. +Proof. + induction l; simpl; intuition. +Qed. + +Lemma notIn_app A (x:A) l1: forall l2, notIn x (l1++l2) <-> (notIn x l1 /\ notIn x l2). +Proof. + induction l1; simpl. + - intuition. + - intros; rewrite IHl1. intuition. +Qed. + + +Lemma In_Permutation A (l1 l2: list A): Permutation l1 l2 -> forall x, In x l1 -> In x l2. +Proof. + induction 1; simpl; intuition. +Qed. + +Lemma Permutation_incl A (l1 l2: list A): Permutation l1 l2 -> incl l1 l2. +Proof. + unfold incl; intros; eapply In_Permutation; eauto. +Qed. + +Lemma notIn_incl A (l1 l2: list A) x: incl l1 l2 -> notIn x l2 -> notIn x l1. +Proof. + unfold incl; rewrite <- ! notIn_iff; intuition. +Qed. + + +Definition disjoint {A: Type} (l l':list A) : Prop := forall x, In x l -> notIn x l'. + +Lemma disjoint_sym_imp A (l1 l2: list A): disjoint l1 l2 -> disjoint l2 l1. +Proof. + unfold disjoint. intros H x H1. generalize (H x). rewrite <- !notIn_iff. intuition. +Qed. + +Lemma disjoint_sym A (l1 l2: list A): disjoint l1 l2 <-> disjoint l2 l1. +Proof. + constructor 1; apply disjoint_sym_imp; auto. +Qed. + + +Lemma disjoint_cons_l A (x:A) (l1 l2: list A): disjoint (x::l1) l2 <-> (notIn x l2) /\ (disjoint l1 l2). +Proof. + unfold disjoint. simpl; intuition subst; auto. +Qed. + +Lemma disjoint_cons_r A (x:A) (l1 l2: list A): disjoint l1 (x::l2) <-> (notIn x l1) /\ (disjoint l1 l2). +Proof. + rewrite disjoint_sym, disjoint_cons_l, disjoint_sym; intuition. +Qed. + +Lemma disjoint_app_r A (l l1 l2: list A): disjoint l (l1++l2) <-> (disjoint l l1 /\ disjoint l l2). +Proof. + unfold disjoint. intuition. + - generalize (H x H0). rewrite notIn_app; intuition. + - generalize (H x H0). rewrite notIn_app; intuition. + - rewrite notIn_app; intuition. +Qed. + +Lemma disjoint_app_l A (l l1 l2: list A): disjoint (l1++l2) l <-> (disjoint l1 l /\ disjoint l2 l). +Proof. + rewrite disjoint_sym, disjoint_app_r; intuition; rewrite disjoint_sym; auto. +Qed. + +Lemma disjoint_incl_r A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l l2 -> disjoint l l1. +Proof. + unfold disjoint. intros; eapply notIn_incl; eauto. +Qed. + +Lemma disjoint_incl_l A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l2 l -> disjoint l1 l. +Proof. + intros; rewrite disjoint_sym. eapply disjoint_incl_r; eauto. rewrite disjoint_sym; auto. +Qed. + + +Module ParallelizablityChecking (L: SeqLanguage). + +Include ParallelSemantics L. + + +(** * Preliminary notions on frames *) + +Lemma notIn_dec (x: R.t) l : { notIn x l } + { In x l }. +Proof. + destruct (In_dec R.eq_dec x l). constructor 2; auto. + constructor 1; rewrite <- notIn_iff. auto. +Qed. + +Fixpoint frame_assign m1 (f: list R.t) m2 := + match f with + | nil => m1 + | x::f' => frame_assign (assign m1 x (m2 x)) f' m2 + end. + +Lemma frame_assign_def f: forall m1 m2 x, + frame_assign m1 f m2 x = if notIn_dec x f then m1 x else m2 x. +Proof. + induction f as [|y f] ; simpl; auto. + - intros; destruct (notIn_dec x []); simpl in *; tauto. + - intros; rewrite IHf; destruct (notIn_dec x (y::f)); simpl in *. + + destruct (notIn_dec x f); simpl in *; intuition. + rewrite assign_diff; auto. + rewrite <- notIn_iff in *; intuition. + + destruct (notIn_dec x f); simpl in *; intuition subst. + rewrite assign_eq; auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Lemma frame_assign_In m1 f m2 x: + In x f -> frame_assign m1 f m2 x = m2 x. +Proof. + intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Lemma frame_assign_notIn m1 f m2 x: + notIn x f -> frame_assign m1 f m2 x = m1 x. +Proof. + intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Definition frame_eq (frame: R.t -> Prop) (om1 om2: option mem): Prop := + match om1 with + | Some m1 => exists m2, om2 = Some m2 /\ forall x, (frame x) -> m1 x = m2 x + | None => om2 = None + end. + +Lemma frame_eq_list_split f1 (f2: R.t -> Prop) om1 om2: + frame_eq (fun x => In x f1) om1 om2 -> + (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> f2 x -> notIn x f1 -> m1 x = m2 x) -> + frame_eq f2 om1 om2. +Proof. + unfold frame_eq; destruct om1 as [ m1 | ]; simpl; auto. + intros (m2 & H0 & H1); subst. + intros H. + eexists; intuition eauto. + destruct (notIn_dec x f1); auto. +Qed. + +(* +Lemma frame_eq_res_eq f om1 om2: + frame_eq (fun x => In x f) om1 om2 -> + (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> notIn x f -> m1 x = m2 x) -> + res_eq om1 om2. +Proof. + intros H H0; lapply (frame_eq_list_split f (fun _ => True) om1 om2 H); eauto. + clear H H0; unfold frame_eq, res_eq. destruct om1; simpl; firstorder. +Qed. +*) + +(** * Writing frames *) + +Fixpoint macro_wframe(i:macro): list R.t := + match i with + | nil => nil + | a::i' => (fst a)::(macro_wframe i') + end. + +Lemma macro_wframe_correct i m' old: forall m tmp, + macro_prun i m tmp old = Some m' -> + forall x, notIn x (macro_wframe i) -> m' x = m x. +Proof. + induction i as [|[y e] i']; simpl. + - intros m tmp H x H0; inversion_clear H; auto. + - intros m tmp H x (H1 & H2); destruct (exp_eval e tmp old); simpl; try congruence. + cutrewrite (m x = assign m y v x); eauto. + rewrite assign_diff; auto. +Qed. + +Lemma macro_prun_fequiv i old: forall m1 m2 tmp, + frame_eq (fun x => In x (macro_wframe i)) (macro_prun i m1 tmp old) (macro_prun i m2 tmp old). +Proof. + induction i as [|[y e] i']; simpl. + - intros m1 m2 tmp; eexists; intuition eauto. + - intros m1 m2 tmp. destruct (exp_eval e tmp old); simpl; auto. + eapply frame_eq_list_split; eauto. clear IHi'. + intros m1' m2' x H1 H2. + lapply (macro_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. + lapply (macro_wframe_correct i' m2' old (assign m2 y v) (assign tmp y v)); eauto. + intros Xm2 Xm1 H H0. destruct H. + + subst. rewrite Xm1, Xm2; auto. rewrite !assign_eq. auto. + + rewrite <- notIn_iff in H0; tauto. +Qed. + +Lemma macro_prun_None i m1 m2 tmp old: + macro_prun i m1 tmp old = None -> + macro_prun i m2 tmp old = None. +Proof. + intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). + rewrite H; simpl; auto. +Qed. + +Lemma macro_prun_Some i m1 m2 tmp old m1': + macro_prun i m1 tmp old = Some m1' -> + res_eq (Some (frame_assign m2 (macro_wframe i) m1')) (macro_prun i m2 tmp old). +Proof. + intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). + rewrite H; simpl. + intros (m2' & H1 & H2). + eexists; intuition eauto. + rewrite frame_assign_def. + lapply (macro_wframe_correct i m2' old m2 tmp); eauto. + destruct (notIn_dec x (macro_wframe i)); auto. + intros X; rewrite X; auto. +Qed. + +Fixpoint bblock_wframe(p:bblock): list R.t := + match p with + | nil => nil + | i::p' => (macro_wframe i)++(bblock_wframe p') + end. + +Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm. + +Lemma bblock_wframe_Permutation p p': + Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). +Proof. + induction 1 as [|i p p'|i1 i2 p|p1 p2 p3]; simpl; auto. + - rewrite! app_assoc; auto. + - eapply Permutation_trans; eauto. +Qed. + +(* +Lemma bblock_wframe_correct p m' old: forall m, + prun_iw p m old = Some m' -> + forall x, notIn x (bblock_wframe p) -> m' x = m x. +Proof. + induction p as [|i p']; simpl. + - intros m H; inversion_clear H; auto. + - intros m H x; rewrite notIn_app; intros (H1 & H2). + remember (macro_prun i m old old) as om. + destruct om as [m1|]; simpl. + + eapply eq_trans. + eapply IHp'; eauto. + eapply macro_wframe_correct; eauto. + + inversion H. +Qed. + +Lemma prun_iw_fequiv p old: forall m1 m2, + frame_eq (fun x => In x (bblock_wframe p)) (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + induction p as [|i p']; simpl. + - intros m1 m2; eexists; intuition eauto. + - intros m1 m2; generalize (macro_prun_fequiv i old m1 m2 old). + remember (macro_prun i m1 old old) as om. + destruct om as [m1'|]; simpl. + + intros (m2' & H1 & H2). rewrite H1; simpl. + eapply frame_eq_list_split; eauto. clear IHp'. + intros m1'' m2'' x H3 H4. rewrite in_app_iff. + intros X X2. assert (X1: In x (macro_wframe i)). { destruct X; auto. rewrite <- notIn_iff in X2; tauto. } + clear X. + lapply (bblock_wframe_correct p' m1'' old m1'); eauto. + lapply (bblock_wframe_correct p' m2'' old m2'); eauto. + intros Xm2' Xm1'. + rewrite Xm1', Xm2'; auto. + + intro H; rewrite H; simpl; auto. +Qed. + +Lemma prun_iw_equiv p m1 m2 old: + (forall x, notIn x (bblock_wframe p) -> m1 x = m2 x) -> + res_eq (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + intros; eapply frame_eq_res_eq. + eapply prun_iw_fequiv. + intros m1' m2' x H1 H2 H0.Require + lapply (bblock_wframe_correct p m1' old m1); eauto. + lapply (bblock_wframe_correct p m2' old m2); eauto. + intros X2 X1; rewrite X1, X2; auto. +Qed. +*) + +(** * Checking that parallel semantics is deterministic *) + +Fixpoint is_det (p: bblock): Prop := + match p with + | nil => True + | i::p' => + disjoint (macro_wframe i) (bblock_wframe p') (* no WRITE-AFTER-WRITE *) + /\ is_det p' + end. + +Lemma is_det_Permutation p p': + Permutation p p' -> is_det p -> is_det p'. +Proof. + induction 1; simpl; auto. + - intros; intuition. eapply disjoint_incl_r. 2: eauto. + eapply Permutation_incl. eapply Permutation_sym. + eapply bblock_wframe_Permutation; auto. + - rewrite! disjoint_app_r in * |- *. intuition. + rewrite disjoint_sym; auto. +Qed. + +Theorem is_det_correct p p': + Permutation p p' -> + is_det p -> + forall m old, res_eq (prun_iw p m old) (prun_iw p' m old). +Proof. + induction 1 as [ | i p p' | i1 i2 p | p1 p2 p3 ]; simpl; eauto. + - intros [H0 H1] m old. + remember (macro_prun i m old old) as om0. + destruct om0 as [ m0 | ]; simpl; auto. + - rewrite disjoint_app_r. + intros ([Z1 Z2] & Z3 & Z4) m old. + remember (macro_prun i2 m old old) as om2. + destruct om2 as [ m2 | ]; simpl; auto. + + remember (macro_prun i1 m old old) as om1. + destruct om1 as [ m1 | ]; simpl; auto. + * lapply (macro_prun_Some i2 m m1 old old m2); simpl; auto. + lapply (macro_prun_Some i1 m m2 old old m1); simpl; auto. + intros (m1' & Hm1' & Xm1') (m2' & Hm2' & Xm2'). + rewrite Hm1', Hm2'; simpl. + eapply prun_iw_equiv. + intros x; rewrite <- Xm1', <- Xm2'. clear Xm2' Xm1' Hm1' Hm2' m1' m2'. + rewrite frame_assign_def. + rewrite disjoint_sym in Z1; unfold disjoint in Z1. + destruct (notIn_dec x (macro_wframe i1)) as [ X1 | X1 ]. + { rewrite frame_assign_def; destruct (notIn_dec x (macro_wframe i2)) as [ X2 | X2 ]; auto. + erewrite (macro_wframe_correct i2 m2 old m old); eauto. + erewrite (macro_wframe_correct i1 m1 old m old); eauto. + } + rewrite frame_assign_notIn; auto. + * erewrite macro_prun_None; eauto. simpl; auto. + + remember (macro_prun i1 m old old) as om1. + destruct om1 as [ m1 | ]; simpl; auto. + erewrite macro_prun_None; eauto. + - intros; eapply res_eq_trans. + eapply IHPermutation1; eauto. + eapply IHPermutation2; eauto. + eapply is_det_Permutation; eauto. +Qed. + +(** * Standard Frames *) + +Fixpoint exp_frame (e: exp): list R.t := + match e with + | Name x => x::nil + | Op o le => list_exp_frame le + | Old e => exp_frame e + end +with list_exp_frame (le: list_exp): list R.t := + match le with + | Enil => nil + | Econs e le' => exp_frame e ++ list_exp_frame le' + | LOld le => list_exp_frame le + end. + +Lemma exp_frame_correct e old1 old2: + (forall x, In x (exp_frame e) -> old1 x = old2 x) -> + forall m1 m2, (forall x, In x (exp_frame e) -> m1 x = m2 x) -> + (exp_eval e m1 old1)=(exp_eval e m2 old2). +Proof. + induction e using exp_mut with (P0:=fun l => (forall x, In x (list_exp_frame l) -> old1 x = old2 x) -> forall m1 m2, (forall x, In x (list_exp_frame l) -> m1 x = m2 x) -> + (list_exp_eval l m1 old1)=(list_exp_eval l m2 old2)); simpl; auto. + - intros H1 m1 m2 H2; rewrite H2; auto. + - intros H1 m1 m2 H2; erewrite IHe; eauto. + - intros H1 m1 m2 H2; erewrite IHe, IHe0; eauto; + intros; (eapply H1 || eapply H2); rewrite in_app_iff; auto. +Qed. + +Fixpoint macro_frame (i: macro): list R.t := + match i with + | nil => nil + | a::i' => (fst a)::(exp_frame (snd a) ++ macro_frame i') + end. + +Lemma macro_wframe_frame i x: In x (macro_wframe i) -> In x (macro_frame i). +Proof. + induction i as [ | [y e] i']; simpl; intuition. +Qed. + + +Lemma macro_frame_correct i wframe old1 old2: forall m tmp1 tmp2, + (disjoint (macro_frame i) wframe) -> + (forall x, notIn x wframe -> old1 x = old2 x) -> + (forall x, notIn x wframe -> tmp1 x = tmp2 x) -> + macro_prun i m tmp1 old1 = macro_prun i m tmp2 old2. +Proof. + induction i as [|[x e] i']; simpl; auto. + intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. + intros (H1 & H2 & H3) H6 H7. + cutrewrite (exp_eval e tmp1 old1 = exp_eval e tmp2 old2). + - destruct (exp_eval e tmp2 old2); auto. + eapply IHi'; eauto. + simpl; intros x0 H0; unfold assign. destruct (R.eq_dec x x0); simpl; auto. + - unfold disjoint in H2; apply exp_frame_correct. + intros;apply H6; auto. + intros;apply H7; auto. +Qed. + +(** * Parallelizability *) + +Fixpoint pararec (p: bblock) (wframe: list R.t): Prop := + match p with + | nil => True + | i::p' => + disjoint (macro_frame i) wframe (* no USE-AFTER-WRITE *) + /\ pararec p' ((macro_wframe i) ++ wframe) + end. + +Lemma pararec_disjoint (p: bblock): forall wframe, pararec p wframe -> disjoint (bblock_wframe p) wframe. +Proof. + induction p as [|i p']; simpl. + - unfold disjoint; simpl; intuition. + - intros wframe [H0 H1]; rewrite disjoint_app_l. + generalize (IHp' _ H1). + rewrite disjoint_app_r. intuition. + eapply disjoint_incl_l. 2: eapply H0. + unfold incl. eapply macro_wframe_frame; eauto. +Qed. + +Lemma pararec_det p: forall wframe, pararec p wframe -> is_det p. +Proof. + induction p as [|i p']; simpl; auto. + intros wframe [H0 H1]. generalize (pararec_disjoint _ _ H1). rewrite disjoint_app_r. + intuition. + - apply disjoint_sym; auto. + - eapply IHp'. eauto. +Qed. + +Lemma pararec_correct p old: forall wframe m, + pararec p wframe -> + (forall x, notIn x wframe -> m x = old x) -> + run p m = prun_iw p m old. +Proof. + elim p; clear p; simpl; auto. + intros i p' X wframe m [H H0] H1. + erewrite macro_run_prun, macro_frame_correct; eauto. + remember (macro_prun i m old old) as om0. + destruct om0 as [m0 | ]; try congruence. + eapply X; eauto. + intro x; rewrite notIn_app. intros [H3 H4]. + rewrite <- H1; auto. + eapply macro_wframe_correct; eauto. +Qed. + +Definition parallelizable (p: bblock) := pararec p nil. + +Theorem parallelizable_correct p m om': + parallelizable p -> (prun p m om' <-> res_eq om' (run p m)). +Proof. + intros H. constructor 1. + - intros (p' & H0 & H1). eapply res_eq_trans; eauto. + erewrite pararec_correct; eauto. + eapply res_eq_sym. + eapply is_det_correct; eauto. + eapply pararec_det; eauto. + - intros; unfold prun. + eexists. constructor 1. 2: apply Permutation_refl. + erewrite pararec_correct in H0; eauto. +Qed. + +End ParallelizablityChecking. + + +Module Type ResourceSet. + +Declare Module R: ResourceNames. + +(** We assume a datatype [t] refining (list R.t) + +This data-refinement is given by an abstract "invariant" match_frame below, +preserved by the following operations. + +*) + +Parameter t: Type. +Parameter match_frame: t -> (list R.t) -> Prop. + +Parameter empty: t. +Parameter empty_match_frame: match_frame empty nil. + +Parameter add: R.t -> t -> t. +Parameter add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). + +Parameter union: t -> t -> t. +Parameter union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). + +Parameter is_disjoint: t -> t -> bool. +Parameter is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. + +End ResourceSet. + + +Lemma lazy_andb_bool_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. +Proof. + destruct b1, b2; intuition. +Qed. + + + + +Module ParallelChecks (L: SeqLanguage) (S:ResourceSet with Module R:=L.LP.R). + +Include ParallelizablityChecking L. + +Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame. + +(** Now, refinement of each operation toward parallelizable *) + +Fixpoint macro_wsframe(i:macro): S.t := + match i with + | nil => S.empty + | a::i' => S.add (fst a) (macro_wsframe i') + end. + +Lemma macro_wsframe_correct i: S.match_frame (macro_wsframe i) (macro_wframe i). +Proof. + induction i; simpl; auto. +Qed. + +Fixpoint exp_sframe (e: exp): S.t := + match e with + | Name x => S.add x S.empty + | Op o le => list_exp_sframe le + | Old e => exp_sframe e + end +with list_exp_sframe (le: list_exp): S.t := + match le with + | Enil => S.empty + | Econs e le' => S.union (exp_sframe e) (list_exp_sframe le') + | LOld le => list_exp_sframe le + end. + +Lemma exp_sframe_correct e: S.match_frame (exp_sframe e) (exp_frame e). +Proof. + induction e using exp_mut with (P0:=fun l => S.match_frame (list_exp_sframe l) (list_exp_frame l)); simpl; auto. +Qed. + +Fixpoint macro_sframe (i: macro): S.t := + match i with + | nil => S.empty + | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (macro_sframe i')) + end. + +Local Hint Resolve exp_sframe_correct. + +Lemma macro_sframe_correct i: S.match_frame (macro_sframe i) (macro_frame i). +Proof. + induction i as [|[y e] i']; simpl; auto. +Qed. + +Local Hint Resolve macro_wsframe_correct macro_sframe_correct. + +Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := + match p with + | nil => true + | i::p' => + S.is_disjoint (macro_sframe i) wsframe (* no USE-AFTER-WRITE *) + &&& is_pararec p' (S.union (macro_wsframe i) wsframe) + end. + +Lemma is_pararec_correct (p: bblock): forall s l, S.match_frame s l -> (is_pararec p s)=true -> (pararec p l). +Proof. + induction p; simpl; auto. + intros s l H1 H2; rewrite lazy_andb_bool_true in H2. destruct H2 as [H2 H3]. + constructor 1; eauto. +Qed. + +Definition is_parallelizable (p: bblock) := is_pararec p S.empty. + +Lemma is_para_correct_aux p: is_parallelizable p = true -> parallelizable p. +Proof. + unfold is_parallelizable, parallelizable; intros; eapply is_pararec_correct; eauto. +Qed. + +Theorem is_parallelizable_correct p: + is_parallelizable p = true -> forall m om', (prun p m om' <-> res_eq om' (run p m)). +Proof. + intros; apply parallelizable_correct. + apply is_para_correct_aux. auto. +Qed. + +End ParallelChecks. + + + + +Require Import PArith. +Require Import MSets.MSetPositive. + +Module PosResourceSet <: ResourceSet with Module R:=Pos. + +Module R:=Pos. + +(** We assume a datatype [t] refining (list R.t) + +This data-refinement is given by an abstract "invariant" match_frame below, +preserved by the following operations. + +*) + +Definition t:=PositiveSet.t. + +Definition match_frame (s:t) (l:list R.t): Prop + := forall x, PositiveSet.In x s <-> In x l. + +Definition empty:=PositiveSet.empty. + +Lemma empty_match_frame: match_frame empty nil. +Proof. + unfold match_frame, empty, PositiveSet.In; simpl; intuition. +Qed. + +Definition add: R.t -> t -> t := PositiveSet.add. + +Lemma add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). +Proof. + unfold match_frame, add; simpl. + intros s x l H y. rewrite PositiveSet.add_spec, H. + intuition. +Qed. + +Definition union: t -> t -> t := PositiveSet.union. +Lemma union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). +Proof. + unfold match_frame, union. + intros s1 s2 l1 l2 H1 H2 x. rewrite PositiveSet.union_spec, H1, H2. + intuition. +Qed. + +Fixpoint is_disjoint (s s': PositiveSet.t) : bool := + match s with + | PositiveSet.Leaf => true + | PositiveSet.Node l o r => + match s' with + | PositiveSet.Leaf => true + | PositiveSet.Node l' o' r' => + if (o &&& o') then false else (is_disjoint l l' &&& is_disjoint r r') + end + end. + +Lemma is_disjoint_spec_true s: forall s', is_disjoint s s' = true -> forall x, PositiveSet.In x s -> PositiveSet.In x s' -> False. +Proof. + unfold PositiveSet.In; induction s as [ |l IHl o r IHr]; simpl; try discriminate. + destruct s' as [|l' o' r']; simpl; try discriminate. + intros X. + assert (H: ~(o = true /\ o'=true) /\ is_disjoint l l' = true /\ is_disjoint r r'=true). + { destruct o, o', (is_disjoint l l'), (is_disjoint r r'); simpl in X; intuition. } + clear X; destruct H as (H & H1 & H2). + destruct x as [i|i|]; simpl; eauto. +Qed. + +Lemma is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. +Proof. + unfold match_frame, disjoint. + intros s1 s2 l1 l2 H1 H2 H3 x. + rewrite <- notIn_iff, <- H1, <- H2. + intros H4 H5; eapply is_disjoint_spec_true; eauto. +Qed. + +End PosResourceSet. diff --git a/mppa_k1c/abstractbb/README.md b/mppa_k1c/abstractbb/README.md new file mode 100644 index 00000000..69e5defc --- /dev/null +++ b/mppa_k1c/abstractbb/README.md @@ -0,0 +1,12 @@ +# Coq sources of AbstractBasicBlocks + +- [AbstractBasicBlocksDef](AbstractBasicBlocksDef.v): syntax and sequential semantics of abstract basic blocks (on which we define our analyzes). +This syntax and semantics is parametrized in order to adapt the language for different concrete basic block languages. + +- [Parallelizability](Parallelizability.v): define the parallel semantics and the 'is_parallelizable' function which tests whether the sequential run of a given abstract basic block is the same than a parallel run. + +- [DepTreeTheory](DepTreeTheory.v): defines a theory of dependency trees, such that two basic blocks with the same dependency tree have the same sequential semantics. In practice, permuting the instructions inside a basic block while perserving the dependencies of assignments should not change the dependency tree. The idea is to verify list schedulings, following ideas of [Formal verification of translation validators proposed by Tristan and Leroy](https://hal.inria.fr/inria-00289540/). + +- [ImpDep](ImpDep.v): adds a hash-consing mechanism to trees of [DepTreeTheory](DepTreeTheory.v), and thus provides an efficient "equality" test (a true answer ensures that the two basic blocks in input have the same sequential semantics) in order to check the correctness of list schedulings. + +- [DepExample](DepExample.v) defines a toy language (syntax and semantics); [DepExampleEqTest](DepExampleEqTest.v) defines a compiler of the toy language into abstract basic blocks and derives an equality test for the toy language; [DepExampleParallelTest](DepExampleParallelTest.v) derives a parallelizability test from the previous compiler; [DepExampleDemo](DepExampleDemo.v) is a test-suite for both tetsts. -- cgit From 2f33dd16ce2f1ac423076b217c71f105ac5e66c8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 13 Feb 2019 15:18:01 +0100 Subject: We have one example that exceeds a total latency of 5000, better simply not constrain this limit. --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 040e9e8d..fa11a298 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -506,7 +506,7 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let build_problem bb = - { max_latency = 5000; resource_bounds = resource_bounds; + { max_latency = -1; resource_bounds = resource_bounds; instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } let rec find_min_opt (l: int option list) = -- cgit From 15a6e1b96a2668de4a100582870e6e0307e585a9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 14 Feb 2019 14:40:09 +0100 Subject: Proving verify_schedule_correct with axioms --- mppa_k1c/PostpassScheduling.v | 135 ++++++++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingproof.v | 14 ---- 2 files changed, 132 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 10331f15..e9328b14 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -11,7 +11,7 @@ (* *********************************************************************) Require Import Coqlib Errors AST Integers. -Require Import Asmblock Axioms. +Require Import Asmblock Axioms Memory Globalenvs. Local Open Scope error_monad_scope. @@ -21,7 +21,93 @@ Axiom schedule: bblock -> list bblock. Extract Constant schedule => "PostpassSchedulingOracle.schedule". -(* Lemmas necessary for defining concat_all *) +(** Specification of the "coming soon" Asmblockdeps.v *) +Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + | bblock_equiv_intro: + (forall rs m, + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> + bblock_equiv ge f bb bb'. + +Axiom regset': Type. +Axiom mem': Type. +Inductive state' := State': regset' -> mem' -> state'. +Inductive outcome' := Next' : regset' -> mem' -> outcome' | Stuck' : outcome'. + +Axiom bblock': Type. +Axiom exec': genv -> function -> bblock' -> regset' -> mem' -> outcome'. +Axiom match_states: state -> state' -> Prop. +Axiom trans_block: bblock -> bblock'. +Axiom trans_state: state -> state'. + +Axiom trans_state_match: forall S, match_states S (trans_state S). + +Inductive bblock_equiv' (ge: Genv.t fundef unit) (f: function) (bb bb': bblock') := + | bblock_equiv_intro': + (forall rs m, + exec' ge f bb rs m = exec' ge f bb' rs m) -> + bblock_equiv' ge f bb bb'. + +Definition exec := exec_bblock. + +Axiom forward_simu: + forall rs1 m1 rs2 m2 rs1' m1' b ge fn, + exec ge fn b rs1 m1 = Next rs2 m2 -> + match_states (State rs1 m1) (State' rs1' m1') -> + exists rs2' m2', + exec' ge fn (trans_block b) rs1' m1' = Next' rs2' m2' + /\ match_states (State rs2 m2) (State' rs2' m2'). + +Axiom state_equiv: + forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. + +Lemma trans_state_State: + forall rs m, + exists rs' m', trans_state (State rs m) = State' rs' m'. +Proof. +Admitted. + +Lemma trans_equiv_stuck: + forall b1 b2 ge fn rs1 m1 rs2 m2, + bblock_equiv' ge fn (trans_block b1) (trans_block b2) -> + (exec ge fn b1 rs1 m1 = Stuck <-> exec ge fn b2 rs2 m2 = Stuck). +Proof. +Admitted. + +Lemma bblock_equiv'_comm: + forall ge fn b1 b2, + bblock_equiv' ge fn b1 b2 <-> bblock_equiv' ge fn b2 b1. +Proof. +Admitted. + +Theorem trans_exec: + forall b1 b2 ge f, bblock_equiv' ge f (trans_block b1) (trans_block b2) -> bblock_equiv ge f b1 b2. +Proof. + repeat constructor. intros rs1 m1. + destruct (exec_bblock _ _ b1 _ _) as [rs2 m2|] eqn:EXEB; destruct (exec_bblock _ _ b2 _ _) as [rs3 m3|] eqn:EXEB2; auto. + - pose (trans_state_State rs1 m1). destruct e as (rs1' & m1' & TEQ). + exploit forward_simu. + eapply EXEB. + erewrite <- TEQ. eapply trans_state_match. + intros (rs2' & m2' & EXEB' & MS). + exploit forward_simu. + eapply EXEB2. + erewrite <- TEQ. eapply trans_state_match. + intros (rs3' & m3' & EXEB'2 & MS2). inv H. + rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. + exploit (state_equiv (State rs2 m2) (State rs3 m3) (State' rs2' m2')). eauto. + congruence. + - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. rewrite EXEB2 in EXEB. discriminate. + - rewrite trans_equiv_stuck in EXEB; eauto. rewrite EXEB in EXEB2. discriminate. +Qed. + +(* TODO - replace it by the actual bblock_equivb' *) +Definition bblock_equivb' (b1 b2: bblock') := true. + +Axiom bblock_equiv'_eq: + forall ge fn b1 b2, + bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. + +(* Lemmas necessary for defining concat_all *) Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. Proof. intros. destruct l; simpl. @@ -192,7 +278,11 @@ Proof. + apply IHlbb in EQ. assumption. Qed. -Definition verify_schedule (bb bb' : bblock) : res unit := OK tt. +Definition verify_schedule (bb bb' : bblock) : res unit := + match (bblock_equivb' (trans_block bb) (trans_block bb')) with + | true => OK tt + | false => Error (msg "PostpassScheduling.verify_schedule") + end. Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). @@ -214,6 +304,12 @@ Proof. intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. Qed. +Lemma verify_schedule_no_header: + forall bb bb', + verify_schedule (no_header bb) bb' = verify_schedule bb bb'. +Proof. +Admitted. + Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. @@ -231,6 +327,13 @@ Proof. intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. Qed. +Lemma stick_header_verify_schedule: + forall hd bb' hbb' bb, + stick_header hd bb' = hbb' -> + verify_schedule bb bb' = verify_schedule bb hbb'. +Proof. +Admitted. + Definition stick_header_code (h : list label) (lbb : list bblock) := match (head lbb) with | None => Error (msg "PostpassScheduling.stick_header: empty schedule") @@ -271,6 +374,16 @@ Proof. simpl. assumption. Qed. +Lemma stick_header_code_concat_all: + forall hd lbb hlbb tbb, + stick_header_code hd lbb = OK hlbb -> + concat_all lbb = OK tbb -> + exists htbb, + concat_all hlbb = OK htbb + /\ stick_header hd tbb = htbb. +Proof. +Admitted. + Definition do_schedule (bb: bblock) : list bblock := if (Z.eqb (size bb) 1) then bb::nil else schedule bb. @@ -321,6 +434,22 @@ Proof. - apply verified_schedule_no_header_in_middle in H. assumption. Qed. +Theorem verified_schedule_correct: + forall ge f bb lbb, + verified_schedule bb = OK lbb -> + exists tbb, + concat_all lbb = OK tbb + /\ bblock_equiv 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. + apply trans_exec. apply bblock_equiv'_eq. unfold verify_schedule in EQ0. + destruct (bblock_equivb' _ _); auto; try discriminate. +Qed. + Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := match lbb with | nil => OK nil diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 492687cd..2c3b8454 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,20 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - | bblock_equiv_intro: - (forall rs m, - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> - bblock_equiv ge f bb bb'. - -(* Axioms that verified_schedule must verify *) -Axiom verified_schedule_correct: - forall ge f bb lbb, - verified_schedule bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb - /\ bblock_equiv ge f bb tbb. - Remark builtin_body_nil: forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. Proof. -- cgit From 35b2c76267c50eb56cfa89371a3627f1bd46ff1b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 14 Feb 2019 15:44:27 +0100 Subject: Some more lemma proving in PostpassScheduling --- mppa_k1c/PostpassScheduling.v | 83 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 73 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index e9328b14..6f26ac58 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -60,6 +60,14 @@ Axiom forward_simu: Axiom state_equiv: forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. + +(* TODO - replace it by the actual bblock_equivb' *) +Definition bblock_equivb' (b1 b2: bblock') := true. + +Axiom bblock_equiv'_eq: + forall ge fn b1 b2, + bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. + Lemma trans_state_State: forall rs m, exists rs' m', trans_state (State rs m) = State' rs' m'. @@ -77,7 +85,8 @@ Lemma bblock_equiv'_comm: forall ge fn b1 b2, bblock_equiv' ge fn b1 b2 <-> bblock_equiv' ge fn b2 b1. Proof. -Admitted. + intros. repeat constructor. all: inv H; congruence. +Qed. Theorem trans_exec: forall b1 b2 ge f, bblock_equiv' ge f (trans_block b1) (trans_block b2) -> bblock_equiv ge f b1 b2. @@ -100,12 +109,7 @@ Proof. - rewrite trans_equiv_stuck in EXEB; eauto. rewrite EXEB in EXEB2. discriminate. Qed. -(* TODO - replace it by the actual bblock_equivb' *) -Definition bblock_equivb' (b1 b2: bblock') := true. -Axiom bblock_equiv'_eq: - forall ge fn b1 b2, - bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. (* Lemmas necessary for defining concat_all *) Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. @@ -122,6 +126,8 @@ Proof. - intros. rewrite <- app_comm_cons. discriminate. Qed. + + Definition check_size bb := if zlt Ptrofs.max_unsigned (size bb) then Error (msg "PostpassSchedulingproof.check_size") @@ -155,7 +161,7 @@ Next Obligation. - unfold builtin_alone. intros. rewrite H0 in H. assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). apply (H ef args res). contradict H1. auto. -Qed. +Defined. Lemma concat2_zlt_size: forall a b bb, @@ -233,6 +239,8 @@ Proof. destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. Qed. + + Fixpoint concat_all (lbb: list bblock) : res bblock := match lbb with | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") @@ -278,6 +286,8 @@ Proof. + apply IHlbb in EQ. assumption. Qed. + + Definition verify_schedule (bb bb' : bblock) : res unit := match (bblock_equivb' (trans_block bb) (trans_block bb')) with | true => OK tt @@ -293,6 +303,8 @@ Proof. apply Z.eqb_eq. assumption. Qed. + + Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. @@ -304,17 +316,24 @@ Proof. intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. Qed. +Axiom trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. + Lemma verify_schedule_no_header: forall bb bb', verify_schedule (no_header bb) bb' = verify_schedule bb bb'. Proof. -Admitted. + intros. unfold verify_schedule. rewrite trans_block_noheader_inv. reflexivity. +Qed. + + Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. Next Obligation. destruct bb; simpl. assumption. Defined. +Axiom trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. + Lemma stick_header_size: forall h bb, size (stick_header h bb) = size bb. Proof. @@ -332,7 +351,42 @@ Lemma stick_header_verify_schedule: stick_header hd bb' = hbb' -> verify_schedule bb bb' = verify_schedule bb hbb'. Proof. -Admitted. + intros. unfold verify_schedule. rewrite <- H. rewrite trans_block_header_inv. reflexivity. +Qed. + +Lemma check_size_stick_header: + forall bb hd, + check_size bb = check_size (stick_header hd bb). +Proof. + intros. unfold check_size. rewrite stick_header_size. reflexivity. +Qed. + +Lemma stick_header_concat2: + forall bb bb' hd tbb, + concat2 bb bb' = OK tbb -> + concat2 (stick_header hd bb) bb' = OK (stick_header hd tbb). +Proof. + intros. monadInv H. erewrite check_size_stick_header in EQ. + unfold concat2. rewrite EQ. rewrite EQ1. simpl. + destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. + destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. + - destruct c. + + destruct i. discriminate. + + inv EQ2. unfold stick_header; simpl. reflexivity. + - inv EQ2. unfold stick_header; simpl. reflexivity. +Qed. + +Lemma stick_header_concat_all: + forall bb c tbb hd, + concat_all (bb :: c) = OK tbb -> + concat_all (stick_header hd bb :: c) = OK (stick_header hd tbb). +Proof. + intros. simpl in *. destruct c; try congruence. + monadInv H. rewrite EQ. simpl. + apply stick_header_concat2. assumption. +Qed. + + Definition stick_header_code (h : list label) (lbb : list bblock) := match (head lbb) with @@ -382,7 +436,14 @@ Lemma stick_header_code_concat_all: concat_all hlbb = OK htbb /\ stick_header hd tbb = htbb. Proof. -Admitted. + intros. exists (stick_header hd tbb). split; auto. + destruct lbb. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. + apply stick_header_concat_all. assumption. +Qed. + + Definition do_schedule (bb: bblock) : list bblock := if (Z.eqb (size bb) 1) then bb::nil else schedule bb. @@ -450,6 +511,8 @@ Proof. destruct (bblock_equivb' _ _); auto; try discriminate. Qed. + + Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := match lbb with | nil => OK nil -- cgit From 3a1f893783ce2933cb1fc57504a482f3684c5720 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 14 Feb 2019 17:54:52 +0100 Subject: More lemmas in PostpassScheduling --- mppa_k1c/PostpassScheduling.v | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 6f26ac58..64ad0db6 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -57,6 +57,18 @@ Axiom forward_simu: exec' ge fn (trans_block b) rs1' m1' = Next' rs2' m2' /\ match_states (State rs2 m2) (State' rs2' m2'). +Axiom forward_simu_stuck: + forall rs1 m1 rs1' m1' b ge fn, + exec ge fn b rs1 m1 = Stuck -> + match_states (State rs1 m1) (State' rs1' m1') -> + exec' ge fn (trans_block b) rs1' m1' = Stuck'. + +Axiom trans_block_reverse_stuck: + forall ge fn b rs m rs' m', + exec' ge fn (trans_block b) rs' m' = Stuck' -> + match_states (State rs m) (State' rs' m') -> + exec ge fn b rs m = Stuck. + Axiom state_equiv: forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. @@ -72,14 +84,22 @@ Lemma trans_state_State: forall rs m, exists rs' m', trans_state (State rs m) = State' rs' m'. Proof. -Admitted. + intros. destruct (trans_state _). eauto. +Qed. Lemma trans_equiv_stuck: - forall b1 b2 ge fn rs1 m1 rs2 m2, + forall b1 b2 ge fn rs m, bblock_equiv' ge fn (trans_block b1) (trans_block b2) -> - (exec ge fn b1 rs1 m1 = Stuck <-> exec ge fn b2 rs2 m2 = Stuck). + (exec ge fn b1 rs m = Stuck <-> exec ge fn b2 rs m = Stuck). Proof. -Admitted. + intros. inv H. + pose (trans_state_match (State rs m)). pose (trans_state_State rs m). destruct e as (rs' & m' & TST). rewrite TST in m0. clear TST. + split. + - intros. eapply forward_simu_stuck in H; eauto. rewrite H0 in H. eapply trans_block_reverse_stuck; eassumption. + - intros. eapply forward_simu_stuck in H; eauto. rewrite <- H0 in H. eapply trans_block_reverse_stuck; eassumption. +Qed. + + Lemma bblock_equiv'_comm: forall ge fn b1 b2, @@ -105,8 +125,8 @@ Proof. rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. exploit (state_equiv (State rs2 m2) (State rs3 m3) (State' rs2' m2')). eauto. congruence. - - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. rewrite EXEB2 in EXEB. discriminate. - - rewrite trans_equiv_stuck in EXEB; eauto. rewrite EXEB in EXEB2. discriminate. + - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. unfold exec in EXEB2. rewrite EXEB2 in EXEB. discriminate. + - rewrite trans_equiv_stuck in EXEB; eauto. unfold exec in EXEB. rewrite EXEB in EXEB2. discriminate. Qed. -- cgit From 15ba214895b64f04c840b020e0263fbd3e45924c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 14 Feb 2019 18:01:58 +0100 Subject: Generalizing state' in PostpassScheduling --- mppa_k1c/PostpassScheduling.v | 55 ++++++++++++++++++------------------------- 1 file changed, 23 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 64ad0db6..edc90e57 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -28,13 +28,11 @@ Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) : exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> bblock_equiv ge f bb bb'. -Axiom regset': Type. -Axiom mem': Type. -Inductive state' := State': regset' -> mem' -> state'. -Inductive outcome' := Next' : regset' -> mem' -> outcome' | Stuck' : outcome'. +Axiom state': Type. +Inductive outcome' := Next' : state' -> outcome' | Stuck' : outcome'. Axiom bblock': Type. -Axiom exec': genv -> function -> bblock' -> regset' -> mem' -> outcome'. +Axiom exec': genv -> function -> bblock' -> state' -> outcome'. Axiom match_states: state -> state' -> Prop. Axiom trans_block: bblock -> bblock'. Axiom trans_state: state -> state'. @@ -43,30 +41,30 @@ Axiom trans_state_match: forall S, match_states S (trans_state S). Inductive bblock_equiv' (ge: Genv.t fundef unit) (f: function) (bb bb': bblock') := | bblock_equiv_intro': - (forall rs m, - exec' ge f bb rs m = exec' ge f bb' rs m) -> + (forall s, + exec' ge f bb s = exec' ge f bb' s) -> bblock_equiv' ge f bb bb'. Definition exec := exec_bblock. Axiom forward_simu: - forall rs1 m1 rs2 m2 rs1' m1' b ge fn, + forall rs1 m1 rs2 m2 s1' b ge fn, exec ge fn b rs1 m1 = Next rs2 m2 -> - match_states (State rs1 m1) (State' rs1' m1') -> - exists rs2' m2', - exec' ge fn (trans_block b) rs1' m1' = Next' rs2' m2' - /\ match_states (State rs2 m2) (State' rs2' m2'). + match_states (State rs1 m1) s1' -> + exists s2', + exec' ge fn (trans_block b) s1' = Next' s2' + /\ match_states (State rs2 m2) s2'. Axiom forward_simu_stuck: - forall rs1 m1 rs1' m1' b ge fn, + forall rs1 m1 s1' b ge fn, exec ge fn b rs1 m1 = Stuck -> - match_states (State rs1 m1) (State' rs1' m1') -> - exec' ge fn (trans_block b) rs1' m1' = Stuck'. + match_states (State rs1 m1) s1' -> + exec' ge fn (trans_block b) s1' = Stuck'. Axiom trans_block_reverse_stuck: - forall ge fn b rs m rs' m', - exec' ge fn (trans_block b) rs' m' = Stuck' -> - match_states (State rs m) (State' rs' m') -> + forall ge fn b rs m s', + exec' ge fn (trans_block b) s' = Stuck' -> + match_states (State rs m) s' -> exec ge fn b rs m = Stuck. Axiom state_equiv: @@ -80,20 +78,13 @@ Axiom bblock_equiv'_eq: forall ge fn b1 b2, bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. -Lemma trans_state_State: - forall rs m, - exists rs' m', trans_state (State rs m) = State' rs' m'. -Proof. - intros. destruct (trans_state _). eauto. -Qed. - Lemma trans_equiv_stuck: forall b1 b2 ge fn rs m, bblock_equiv' ge fn (trans_block b1) (trans_block b2) -> (exec ge fn b1 rs m = Stuck <-> exec ge fn b2 rs m = Stuck). Proof. intros. inv H. - pose (trans_state_match (State rs m)). pose (trans_state_State rs m). destruct e as (rs' & m' & TST). rewrite TST in m0. clear TST. + pose (trans_state_match (State rs m)). split. - intros. eapply forward_simu_stuck in H; eauto. rewrite H0 in H. eapply trans_block_reverse_stuck; eassumption. - intros. eapply forward_simu_stuck in H; eauto. rewrite <- H0 in H. eapply trans_block_reverse_stuck; eassumption. @@ -113,17 +104,17 @@ Theorem trans_exec: Proof. repeat constructor. intros rs1 m1. destruct (exec_bblock _ _ b1 _ _) as [rs2 m2|] eqn:EXEB; destruct (exec_bblock _ _ b2 _ _) as [rs3 m3|] eqn:EXEB2; auto. - - pose (trans_state_State rs1 m1). destruct e as (rs1' & m1' & TEQ). + - pose (trans_state_match (State rs1 m1)). exploit forward_simu. eapply EXEB. - erewrite <- TEQ. eapply trans_state_match. - intros (rs2' & m2' & EXEB' & MS). + eapply m. + intros (s2' & EXEB' & MS). exploit forward_simu. eapply EXEB2. - erewrite <- TEQ. eapply trans_state_match. - intros (rs3' & m3' & EXEB'2 & MS2). inv H. + eapply m. + intros (s3' & EXEB'2 & MS2). inv H. rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. - exploit (state_equiv (State rs2 m2) (State rs3 m3) (State' rs2' m2')). eauto. + exploit (state_equiv (State rs2 m2) (State rs3 m3) s2'). eauto. congruence. - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. unfold exec in EXEB2. rewrite EXEB2 in EXEB. discriminate. - rewrite trans_equiv_stuck in EXEB; eauto. unfold exec in EXEB. rewrite EXEB in EXEB2. discriminate. -- cgit From 72504f5f53110f997c998352e916ad6c4434c76d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 15 Feb 2019 10:45:38 +0100 Subject: FIX axiom to be realized issue --- mppa_k1c/PostpassScheduling.v | 29 +++++++++++++++++++++++++++-- mppa_k1c/PostpassSchedulingOracle.ml | 8 ++++++++ 2 files changed, 35 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index edc90e57..8700a472 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -32,9 +32,11 @@ Axiom state': Type. Inductive outcome' := Next' : state' -> outcome' | Stuck' : outcome'. Axiom bblock': Type. +Extract Constant bblock' => "PostpassSchedulingOracle.bblock'". (* FIXME *) Axiom exec': genv -> function -> bblock' -> state' -> outcome'. Axiom match_states: state -> state' -> Prop. Axiom trans_block: bblock -> bblock'. +Extract Constant trans_block => "PostpassSchedulingOracle.trans_block". (* FIXME *) Axiom trans_state: state -> state'. Axiom trans_state_match: forall S, match_states S (trans_state S). @@ -45,6 +47,13 @@ Inductive bblock_equiv' (ge: Genv.t fundef unit) (f: function) (bb bb': bblock') exec' ge f bb s = exec' ge f bb' s) -> bblock_equiv' ge f bb bb'. +Lemma bblock_equiv'_refl: forall ge fn tbb, bblock_equiv' ge fn tbb tbb. +Proof. + repeat constructor. +Qed. + + + Definition exec := exec_bblock. Axiom forward_simu: @@ -72,12 +81,20 @@ Axiom state_equiv: (* TODO - replace it by the actual bblock_equivb' *) -Definition bblock_equivb' (b1 b2: bblock') := true. +Axiom bblock_equivb': bblock' -> bblock' -> bool. +Extract Constant bblock_equivb' => "PostpassSchedulingOracle.bblock_equivb'". (* FIXME *) Axiom bblock_equiv'_eq: forall ge fn b1 b2, bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. +Lemma bblock_equivb'_refl: forall tbb, bblock_equivb' tbb tbb = true. +Proof. + intros. rewrite bblock_equiv'_eq. apply bblock_equiv'_refl. + Unshelve. (* FIXME - problem of Genv and function *) +Admitted. + + Lemma trans_equiv_stuck: forall b1 b2 ge fn rs m, bblock_equiv' ge fn (trans_block b1) (trans_block b2) -> @@ -305,6 +322,14 @@ Definition verify_schedule (bb bb' : bblock) : res unit := | false => Error (msg "PostpassScheduling.verify_schedule") end. +Lemma verify_schedule_refl: + forall bb, verify_schedule bb bb = OK tt. +Proof. + intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. +Qed. + + + Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). Lemma verify_size_size: @@ -480,7 +505,7 @@ Lemma verified_schedule_single_inst: Proof. intros. unfold verified_schedule. unfold do_schedule. rewrite no_header_size. rewrite H. simpl. - unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). simpl. + unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). rewrite verify_schedule_refl. simpl. apply stick_header_code_no_header. rewrite H. reflexivity. Qed. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9126d230..f5742cc2 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -700,3 +700,11 @@ let schedule 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 *) + +type bblock' = int + +let trans_block bb = 1 + +let bblock_equivb' bb1 bb2 = true -- cgit From 3baf98aa8fe0fff0414772176ce0a0095e8b0b32 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 15 Feb 2019 18:05:54 +0100 Subject: Rajout d'opérateurs flottants, travail sur les tests --> à continuer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 28 ++++++- mppa_k1c/Asmblock.v | 39 ++++++++-- mppa_k1c/Asmblockgen.v | 142 +++++++++++------------------------ mppa_k1c/PostpassSchedulingOracle.ml | 45 +++++++++-- mppa_k1c/TargetPrinter.ml | 29 ++++++- 5 files changed, 169 insertions(+), 114 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d7bfaffe..074885f6 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -94,11 +94,17 @@ Inductive instruction : Type := | Pmv (rd rs: ireg) (**r register move *) | Pnegw (rd rs: ireg) (**r negate word *) | Pnegl (rd rs: ireg) (**r negate long *) - | Pfnegd (rd rs: ireg) (**r float negate double *) | 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 *) + | 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 *) + | 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 *) | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (64 bits) *) @@ -139,6 +145,13 @@ Inductive instruction : Type := | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic 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 *) @@ -197,8 +210,14 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs | PArithRR Asmblock.Psxwd rd rs => Psxwd rd rs | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs + | PArithRR Asmblock.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmblock.Pfabsw rd rs => Pfabsw rd rs | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmblock.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmblock.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmblock.Pfwidenlwd rd rs => Pfwidenlwd rd rs | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmblock.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs | PArithRR Asmblock.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs | PArithRR Asmblock.Pfixeddrzz rd rs => Pfixeddrzz rd rs @@ -238,6 +257,13 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 | PArithRRR Asmblock.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmblock.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmblock.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmblock.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmblock.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmblock.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmblock.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + (* RRI32 *) | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3cd300c9..a582e866 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -279,14 +279,21 @@ Inductive arith_name_rr : Type := | Pmv (**r register move *) | Pnegw (**r negate word *) | Pnegl (**r negate long *) - | Pfnegd (**r float negate double *) | Pcvtl2w (**r Convert Long to Word *) | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) - | Pfloatwrnsz (**r Floating Point Conversion from integer (single -> int) *) - | Pfloatdrnsz (**r Floating Point Conversion from integer (float -> long) *) - | Pfixedwrzz (**r Integer conversion from floating point (int -> single) *) - | Pfixeddrzz (**r Integer conversion from floating point (long -> float) *) + + | Pfabsd (**r float absolute double *) + | Pfabsw (**r float absolute word *) + | Pfnegd (**r float negate double *) + | Pfnegw (**r float negate 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) *) + | Pfloatudrnsz (**r Floating Point Conversion from unsigned integer (ulong -> float) *) + | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) + | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) + | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) . Inductive arith_name_ri32 : Type := @@ -328,6 +335,13 @@ Inductive arith_name_rrr : Type := | Pslll (**r shift left logical long *) | Psrll (**r shift right logical long *) | Psral (**r shift right arithmetic long *) + + | Pfaddd (**r float add double *) + | Pfaddw (**r float add word *) + | Pfsbfd (**r float sub double *) + | Pfsbfw (**r float sub word *) + | Pfmuld (**r float multiply double *) + | Pfmulw (**r float multiply word *) . Inductive arith_name_rri32 : Type := @@ -884,11 +898,17 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pmv => rs#d <- (rs#s) | Pnegw => rs#d <- (Val.neg rs#s) | Pnegl => rs#d <- (Val.negl rs#s) - | Pfnegd => rs#d <- (Val.negf rs#s) | Pcvtl2w => rs#d <- (Val.loword rs#s) | Psxwd => rs#d <- (Val.longofint rs#s) | Pzxwd => rs#d <- (Val.longofintu rs#s) + | Pfnegd => rs#d <- (Val.negf rs#s) + | Pfnegw => rs#d <- (Val.negfs rs#s) + | Pfabsd => rs#d <- (Val.absf rs#s) + | Pfabsw => rs#d <- (Val.absfs rs#s) + | Pfnarrowdw => rs#d <- (Val.singleoffloat rs#s) + | Pfwidenlwd => rs#d <- (Val.floatofsingle rs#s) | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) + | Pfloatudrnsz => rs#d <- (match Val.floatoflongu rs#s with Some f => f | _ => Vundef end) | Pfloatdrnsz => rs#d <- (match Val.floatoflong rs#s with Some f => f | _ => Vundef end) | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) | Pfixeddrzz => rs#d <- (match Val.longoffloat rs#s with Some i => i | _ => Vundef end) @@ -937,6 +957,13 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pslll => rs#d <- (Val.shll rs#s1 rs#s2) | Psrll => rs#d <- (Val.shrlu rs#s1 rs#s2) | Psral => rs#d <- (Val.shrl rs#s1 rs#s2) + + | Pfaddd => rs#d <- (Val.addf rs#s1 rs#s2) + | Pfaddw => rs#d <- (Val.addfs rs#s1 rs#s2) + | Pfsbfd => rs#d <- (Val.subf rs#s1 rs#s2) + | Pfsbfw => rs#d <- (Val.subfs rs#s1 rs#s2) + | Pfmuld => rs#d <- (Val.mulf rs#s1 rs#s2) + | Pfmulw => rs#d <- (Val.mulfs rs#s1 rs#s2) end | PArithRRI32 n d s i => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e7fa8f6c..6503e5b3 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -544,21 +544,62 @@ Definition transl_op Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i Paddl RTMP rs RTMP ::i Psrail rd RTMP n ::i k) + + | Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsd rd rs ::i k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsw rd rs ::i k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddd rd rs1 rs2 ::i k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddw rd rs1 rs2 ::i k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsbfd rd rs1 rs2 ::i k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsbfw rd rs1 rs2 ::i k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuld rd rs1 rs2 ::i k) + | 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) | 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) + | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatwrnsz rd rs ::i k) | Ofloatoflong, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatdrnsz rd rs ::i k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatudrnsz rd rs ::i k) | Ointofsingle, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedwrzz rd rs ::i k) | Olongoffloat, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixeddrzz rd rs ::i k) + + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfwidenlwd rd rs ::i k) + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnarrowdw rd rs ::i k) + + | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") @@ -570,7 +611,6 @@ Definition transl_op | Osubfs , _ => Error (msg "Asmblockgen.transl_op: Osubfs") | Omulfs , _ => Error (msg "Asmblockgen.transl_op: Omulfs") | Odivfs , _ => Error (msg "Asmblockgen.transl_op: Odivfs") - | Ofloatoflong , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflong") | Ofloatoflongu , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflongu") | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") @@ -580,114 +620,18 @@ Definition transl_op | Ointuoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointuoffloat") | Ofloatofint , _ => Error (msg "Asmblockgen.transl_op: Ofloatofint") | Ofloatofintu , _ => Error (msg "Asmblockgen.transl_op: Ofloatofintu") - | Ointofsingle , _ => Error (msg "Asmblockgen.transl_op: Ointofsingle") | Ointuofsingle , _ => Error (msg "Asmblockgen.transl_op: Ointuofsingle") - | Osingleofint , _ => Error (msg "Asmblockgen.transl_op: Osingleofint") | Osingleofintu , _ => Error (msg "Asmblockgen.transl_op: Osingleofintu") - | Olongoffloat , _ => Error (msg "Asmblockgen.transl_op: Olongoffloat") | Olonguoffloat , _ => Error (msg "Asmblockgen.transl_op: Olonguoffloat") | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") - -(*| Oabsf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabsd rd rs :: k) - | Oaddf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfaddd rd rs1 rs2 :: k) - | Osubf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsubd rd rs1 rs2 :: k) - | Omulf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmuld rd rs1 rs2 :: k) - | Odivf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdivd rd rs1 rs2 :: k) - - | Onegfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegs rd rs :: k) - | Oabsfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabss rd rs :: k) - | Oaddfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfadds rd rs1 rs2 :: k) - | Osubfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsubs rd rs1 rs2 :: k) - | Omulfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmuls rd rs1 rs2 :: k) - | Odivfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdivs rd rs1 rs2 :: k) - - | Osingleoffloat, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtsd rd rs :: k) - | Ofloatofsingle, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtds rd rs :: k) - - | Ointoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwd rd rs :: k) - | Ointuoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwud rd rs :: k) - | Ofloatofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdw rd rs :: k) - | Ofloatofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdwu rd rs :: k) - | Ointofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtws rd rs :: k) - | Ointuofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtwus rd rs :: k) - | Osingleofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtsw rd rs :: k) - | Osingleofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtswu rd rs :: k) - - | Olongoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtld rd rs :: k) - | Olonguoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtlud rd rs :: k) - | Ofloatoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdl rd rs :: k) - | Ofloatoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtdlu rd rs :: k) - | Olongofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtls rd rs :: k) - | Olonguofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtlus rd rs :: k) - | Osingleoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtsl rd rs :: k) - | Osingleoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfcvtslu rd rs :: k) - -*)| Ocmp cmp, _ => + | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k - + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f5742cc2..54a27966 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -31,10 +31,16 @@ let arith_rr_str = function | Pmv -> "Pmv" | Pnegw -> "Pnegw" | Pnegl -> "Pnegl" - | Pfnegd -> "Pfnegd" | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" + | Pfabsw -> "Pfabsw" + | Pfabsd -> "Pfabsd" + | Pfnegw -> "Pfnegw" + | Pfnegd -> "Pfnegd" + | Pfnarrowdw -> "Pfnarrowdw" + | Pfwidenlwd -> "Pfwidenlwd" | Pfloatwrnsz -> "Pfloatwrnsz" + | Pfloatudrnsz -> "Pfloatudrnsz" | Pfloatdrnsz -> "Pfloatdrnsz" | Pfixedwrzz -> "Pfixedwrzz" | Pfixeddrzz -> "Pfixeddrzz" @@ -60,6 +66,12 @@ let arith_rrr_str = function | Pslll -> "Pslll" | Psrll -> "Psrll" | Psral -> "Psral" + | Pfaddd -> "Pfaddd" + | Pfaddw -> "Pfaddw" + | Pfsbfd -> "Pfsbfd" + | Pfsbfw -> "Pfsbfw" + | Pfmuld -> "Pfmuld" + | Pfmulw -> "Pfmulw" let arith_rri32_str = function | Pcompiw it -> "Pcompiw" @@ -286,6 +298,10 @@ let alu_lite : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 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 + 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 in Array.of_list (List.map resmap resource_names) @@ -347,7 +363,9 @@ type real_instruction = (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) - | Fnegd | Floatwz | Floatdz | Fixedwz | Fixeddz + | Fabsd | Fabsw | Fnegw | Fnegd + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fnarrowdw | Fwidenlwd | Floatwz | Floatdz | Floatudz | Fixedwz | Fixeddz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -374,8 +392,11 @@ let ab_inst_to_real = function | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd | "Pzxwd" -> Zxwd + | "Pfnarrowdw" -> Fnarrowdw + | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz | "Pfloatdrnsz" -> Floatdz + | "Pfloatudrnsz" -> Floatudz | "Pfixedwrzz" -> Fixedwz | "Pfixeddrzz" -> Fixeddz @@ -400,7 +421,16 @@ let ab_inst_to_real = function | "Pret" -> Ret | "Pset" -> Set + | "Pfabsd" -> Fabsd + | "Pfabsw" -> Fabsw + | "Pfnegw" -> Fnegw | "Pfnegd" -> Fnegd + | "Pfaddd" -> Faddd + | "Pfaddw" -> Faddw + | "Pfsbfd" -> Fsbfd + | "Pfsbfw" -> Fsbfw + | "Pfmuld" -> Fmuld + | "Pfmulw" -> Fmulw | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s exception InvalidEncoding @@ -439,7 +469,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Fixedwz | Floatwz | Fixeddz | Floatdz -> mau + | Fixedwz | Floatwz | Fixeddz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -450,7 +480,9 @@ let rec_to_usage r = | Some E27U27L10 -> lsu_acc_y) | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop - | Fnegd -> alu_lite + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -> alu_lite + | Fnarrowdw -> alu_full + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) @@ -458,7 +490,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 - | Floatwz | Fixedwz | Floatdz | Fixeddz -> 4 + | Floatwz | Fixedwz | Floatdz | Floatudz | Fixeddz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd @@ -466,7 +498,8 @@ let real_inst_to_latency = function | Get -> 1 | Set -> 3 | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) - | Fnegd -> 1 + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 4 let rec_to_info r : inst_info = let usage = rec_to_usage r diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 703863b7..da3cf75f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -288,14 +288,26 @@ module Target (*: TARGET*) = fprintf oc " negd %a = %a\n" ireg rd ireg rs | Pnegw(rd, rs) -> fprintf oc " negw %a = %a\n" ireg rd ireg rs - | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n" ireg rs ireg rd | Psxwd(rd, rs) -> fprintf oc " sxwd %a = %a\n" ireg rd ireg rs | Pzxwd(rd, rs) -> fprintf oc " zxwd %a = %a\n" ireg rd ireg rs + | Pfabsd(rd, rs) -> + fprintf oc " fabsd %a = %a\n" ireg rd ireg rs + | Pfabsw(rd, rs) -> + fprintf oc " fabsw %a = %a\n" ireg rd ireg rs + | Pfnegd(rd, rs) -> + fprintf oc " fnegd %a = %a\n" ireg rs ireg rd + | Pfnegw(rd, rs) -> + fprintf oc " fnegw %a = %a\n" ireg rs ireg rd + | Pfnarrowdw(rd, rs) -> + fprintf oc " fnarrowdw %a = %a\n" ireg rs ireg rd + | Pfwidenlwd(rd, rs) -> + fprintf oc " fwidenlwd %a = %a\n" ireg rs ireg rd | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatudrnsz(rd, rs) -> + fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfloatdrnsz(rd, rs) -> fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfixedwrzz(rd, rs) -> @@ -367,6 +379,19 @@ module Target (*: TARGET*) = | Psral (rd, rs1, rs2) -> fprintf oc " srad %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 + | Pfaddw (rd, rs1, rs2) -> + fprintf oc " faddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfsbfd (rd, rs1, rs2) -> + fprintf oc " fsbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfsbfw (rd, rs1, rs2) -> + fprintf oc " fsbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmuld (rd, rs1, rs2) -> + 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 + (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm -- cgit From 05d822afbf41b11fe7937bb14d101f2bb7814651 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Feb 2019 12:26:34 +0100 Subject: reversed the register allocation ordering between float and int registers, to avoid contention --- mppa_k1c/Conventions1.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index b401c43f..59159f61 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -47,13 +47,13 @@ Definition int_caller_save_regs := :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. -Definition float_caller_save_regs := int_caller_save_regs. +Definition float_caller_save_regs := rev int_caller_save_regs. Definition int_callee_save_regs := (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. -Definition float_callee_save_regs := int_callee_save_regs. +Definition float_callee_save_regs := rev int_callee_save_regs. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -- cgit From c4296102ae17e434279ed82df0471b7c50ab2f51 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Feb 2019 19:01:02 +0100 Subject: use a Pfsd (store double) and not a Pfss (store single) for storing doubles --- mppa_k1c/Asm.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 074885f6..7c735bf1 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -304,7 +304,7 @@ Definition basic_to_instruction (b: basic) := | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra ofs | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra ofs | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra ofs - | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfss rd ra ofs + | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfsd rd ra ofs end. -- cgit From f3be94e368c3a6b3453329c5c9f394df13c51bf3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 18 Feb 2019 17:41:56 +0100 Subject: [BROKEN] trying to generalize Sylvain's abstract bb to include a genv. FIXME - DepExampleDemo.v --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 12 +++++- mppa_k1c/abstractbb/DepExampleDemo.v | 6 ++- mppa_k1c/abstractbb/DepExampleEqTest.v | 24 +++++++---- mppa_k1c/abstractbb/DepExampleParallelTest.v | 13 ++++-- mppa_k1c/abstractbb/DepTreeTheory.v | 55 +++++++++++++----------- mppa_k1c/abstractbb/ImpDep.v | 46 +++++++++++--------- mppa_k1c/abstractbb/Parallelizability.v | 64 +++++++++++++++++----------- 7 files changed, 133 insertions(+), 87 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 50ce000e..21e7bd98 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -22,10 +22,12 @@ Parameter value: Type. 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: op -> list value -> option value. +Parameter op_eval: genv -> op -> list value -> option value. End LangParam. @@ -38,6 +40,10 @@ Export P. Local Open Scope list. +Section SEQLANG. + +Variable ge: genv. + Definition mem := R.t -> value. Definition assign (m: mem) (x:R.t) (v: value): mem @@ -58,7 +64,7 @@ Fixpoint exp_eval (e: exp) (m old: mem): option value := | Name x => Some (m x) | Op o le => match list_exp_eval le m old with - | Some lv => op_eval o lv + | Some lv => op_eval ge o lv | _ => None end | Old e => exp_eval e old old @@ -201,6 +207,8 @@ Proof. eauto. Qed. +End SEQLANG. + End MkSeqLanguage. diff --git a/mppa_k1c/abstractbb/DepExampleDemo.v b/mppa_k1c/abstractbb/DepExampleDemo.v index c2079b70..74e8f35e 100644 --- a/mppa_k1c/abstractbb/DepExampleDemo.v +++ b/mppa_k1c/abstractbb/DepExampleDemo.v @@ -7,6 +7,10 @@ Open Scope Z_scope. Module EqTests. +Section TESTS. + +Variable ge: P.genv. + (**** TESTS DRIVER ! ****) Record test_input := { @@ -19,7 +23,7 @@ Record test_input := { Definition run1 (t: test_input): ?? unit := print ((name t) +; " =>");; - DO result <~ bblock_eq_test (verbose t) (p1 t) (p2 t);; + DO result <~ bblock_eq_test ge (verbose t) (p1 t) (p2 t);; assert_b (eqb result (expected t)) "UNEXPECTED RESULT";; if expected t then println " SUCCESS" diff --git a/mppa_k1c/abstractbb/DepExampleEqTest.v b/mppa_k1c/abstractbb/DepExampleEqTest.v index 50bfc2f4..a633ee07 100644 --- a/mppa_k1c/abstractbb/DepExampleEqTest.v +++ b/mppa_k1c/abstractbb/DepExampleEqTest.v @@ -12,6 +12,10 @@ Module P<: ImpParam. Module R := Pos. +Definition genv := unit. + +Section IMP. + Inductive value_wrap := | Std (v:value) (* value = DepExample.value *) | Mem (m:mem) @@ -26,7 +30,7 @@ Inductive op_wrap := | STORE . -Definition op_eval (op: op_wrap) (l:list value_wrap): option value_wrap := +Definition op_eval (ge: genv) (op: op_wrap) (l:list value_wrap): option value_wrap := match op, l with | Imm i, [] => Some (Std i) | ARITH op, [Std v1; Std v2] => Some (Std (arith_op_eval op v1 v2)) @@ -47,7 +51,6 @@ Definition op_eval (op: op_wrap) (l:list value_wrap): option value_wrap := Definition value:=value_wrap. Definition op:=op_wrap. - Definition op_eq (o1 o2: op_wrap): ?? bool := match o1, o2 with | Imm i1, Imm i2 => phys_eq i1 i2 @@ -63,6 +66,7 @@ Proof. destruct o1, o2; wlp_simplify; congruence. Qed. +End IMP. End P. @@ -77,6 +81,9 @@ End L. Module IDT := ImpDepTree L ImpPosDict. +Section SECT. +Variable ge: P.genv. + (** Compilation from DepExample to L *) Definition the_mem: P.R.t := 1. @@ -149,13 +156,13 @@ Definition match_option_state (os: option state) (om:option L.mem): Prop := | None => om = None end. -Lemma comp_op_correct o s m old: match_state s m -> L.exp_eval (comp_op o) m old = Some (P.Std (operand_eval o (rm s))). +Lemma comp_op_correct o s m old: match_state s m -> L.exp_eval ge (comp_op o) m old = Some (P.Std (operand_eval o (rm s))). Proof. destruct 1 as [H1 H2]; destruct o; simpl; auto. rewrite H2; auto. Qed. -Lemma comp_bblock_correct_aux p: forall s m, match_state s m -> match_option_state (sem_bblock p s) (L.run (comp_bblock p) m). +Lemma comp_bblock_correct_aux p: forall s m, match_state s m -> match_option_state (sem_bblock p s) (L.run ge (comp_bblock p) m). Proof. induction p as [| i p IHp]; simpl; eauto. intros s m H; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. @@ -205,7 +212,7 @@ Proof. * rewrite L.assign_diff; auto. Qed. -Lemma comp_bblock_correct p s: match_option_state (sem_bblock p s) (L.run (comp_bblock p) (trans_state s)). +Lemma comp_bblock_correct p s: match_option_state (sem_bblock p s) (L.run ge (comp_bblock p) (trans_state s)). Proof. eapply comp_bblock_correct_aux. apply match_trans_state. Qed. @@ -257,7 +264,7 @@ Proof. - intros; subst; simpl; auto. Qed. -Lemma bblock_equiv_reduce p1 p2: L.bblock_equiv (comp_bblock p1) (comp_bblock p2) -> bblock_equiv p1 p2. +Lemma bblock_equiv_reduce p1 p2: L.bblock_equiv ge (comp_bblock p1) (comp_bblock p2) -> bblock_equiv p1 p2. Proof. unfold L.bblock_equiv, bblock_equiv. intros; eapply res_equiv_from_match. @@ -295,9 +302,9 @@ Definition string_of_op (op: P.op): ?? pstring := Definition bblock_eq_test (verb: bool) (p1 p2: bblock) : ?? bool := if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op (comp_bblock p1) (comp_bblock p2) + IDT.verb_bblock_eq_test string_of_name string_of_op ge (comp_bblock p1) (comp_bblock p2) else - IDT.bblock_eq_test (comp_bblock p1) (comp_bblock p2). + IDT.bblock_eq_test ge (comp_bblock p1) (comp_bblock p2). Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. @@ -310,6 +317,7 @@ Qed. Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. +End SECT. (* TEST: we can coerce this bblock_eq_test into a pure function (even if this is a little unsafe). *) (* Import UnsafeImpure. diff --git a/mppa_k1c/abstractbb/DepExampleParallelTest.v b/mppa_k1c/abstractbb/DepExampleParallelTest.v index 00f33540..35b44683 100644 --- a/mppa_k1c/abstractbb/DepExampleParallelTest.v +++ b/mppa_k1c/abstractbb/DepExampleParallelTest.v @@ -8,13 +8,16 @@ Definition bblock_is_para (p: bblock) : bool := Local Hint Resolve the_mem_separation reg_map_separation. +Section SEC. +Variable ge: P.genv. + (* Actually, almost the same proof script than [comp_bblock_correct_aux] ! We could definitely factorize the proof through a lemma on compilation to macros. *) Lemma comp_bblock_correct_para_iw p: forall sin sout min mout, match_state sin min -> match_state sout mout -> - match_option_state (sem_bblock_par_iw p sin sout) (PChk.prun_iw (comp_bblock p) mout min). + match_option_state (sem_bblock_par_iw p sin sout) (PChk.prun_iw ge (comp_bblock p) mout min). Proof. induction p as [|i p IHp]; simpl; eauto. intros sin sout min mout Hin Hout; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. @@ -141,7 +144,7 @@ Qed. Local Hint Resolve comp_bblock_Permutation res_eq_from_match match_from_res_equiv comp_bblock_correct_para_iw. Lemma bblock_par_iff_prun p s os': - sem_bblock_par p s os' <-> PChk.prun (comp_bblock p) (trans_state s) (trans_option_state os'). + sem_bblock_par p s os' <-> PChk.prun ge (comp_bblock p) (trans_state s) (trans_option_state os'). Proof. unfold sem_bblock_par, PChk.prun. constructor 1. - intros (p' & H1 & H2). @@ -154,8 +157,10 @@ Qed. Theorem bblock_is_para_correct p: bblock_is_para p = true -> forall s os', (sem_bblock_par p s os' <-> res_equiv os' (sem_bblock p s)). Proof. - intros H; generalize (PChk.is_parallelizable_correct _ H); clear H. + intros H; generalize (PChk.is_parallelizable_correct ge _ H); clear H. intros H s os'. rewrite bblock_par_iff_prun, H. constructor; eauto. -Qed. \ No newline at end of file +Qed. + +End SEC. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index 3dff22e1..6f017378 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -41,6 +41,9 @@ Export L. Export LP. Local Open Scope list. +Section DEPTREE. + +Variable ge: genv. (** Dependency Trees of these "bblocks" @@ -63,7 +66,7 @@ Fixpoint tree_eval (t: tree) (m: mem): option value := | Tname x => Some (m x) | Top o l => match list_tree_eval l m with - | Some v => op_eval o v + | Some v => op_eval ge o v | _ => None end | Terase new old => @@ -127,7 +130,7 @@ Definition failsafe (t: tree): bool := match t with | Tname x => true | Top o Tnil => - match op_eval o nil with + match op_eval ge o nil with | Some _ => true | None => false end @@ -138,7 +141,7 @@ Lemma failsafe_correct (t: tree) m: failsafe t = true -> tree_eval t m <> None. Proof. destruct t; simpl; try congruence. destruct l; simpl; try congruence. - destruct (op_eval o nil); try congruence. + destruct (op_eval ge o nil); try congruence. Qed. Fixpoint macro_deps (i: macro) (d old: deps): deps := @@ -168,10 +171,10 @@ Definition bblock_deps: bblock -> deps Lemma tree_eval_exp e od m0 old: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (tree_eval (exp_tree e d od) m0) = exp_eval e m1 old. + (tree_eval (exp_tree e d od) m0) = exp_eval ge e m1 old. Proof. intro H. - induction e using exp_mut with (P0:=fun l => forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval (list_exp_tree l d od) m0 = list_exp_eval l m1 old); simpl; auto. + induction e using exp_mut with (P0:=fun l => forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval (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. @@ -202,14 +205,14 @@ Qed. Lemma tree_eval_macro_Some_correct1 i m0 old od: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall (m1 m2: mem) d, - macro_run i m1 old = Some m2 -> + macro_run ge i m1 old = Some m2 -> (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> (forall x, tree_eval (deps_get (macro_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. - remember (exp_eval e m1 old) as ov. + remember (exp_eval ge e m1 old) as ov. destruct ov. + refine (IHi _ _ _ _ _ _); eauto. clear x0; intros x0. @@ -224,21 +227,21 @@ Qed. Local Hint Resolve tree_eval_macro_Some_correct1 tree_eval_abort. Lemma tree_eval_Some_correct1 p m0: forall (m1 m2: mem) d, - run p m1 = Some m2 -> + run ge p m1 = Some m2 -> (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)). Proof. induction p as [ | i p]; simpl; intros m1 m2 d H. - inversion_clear H; eauto. - intros H0 x0. - remember (macro_run i m1 m1) as om. + remember (macro_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _ _ _ _); eauto. + inversion H. Qed. Lemma bblock_deps_Some_correct1 p m0 m1: - run p m0 = Some m1 + run ge p m0 = Some m1 -> forall x, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x). Proof. intros; eapply tree_eval_Some_correct1; @@ -248,12 +251,12 @@ Qed. Lemma tree_eval_macro_None_correct i m0 old od: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall m1 d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - macro_run i m1 old = None <-> exists x, tree_eval (deps_get (macro_deps i d od) x) m0 = None. + macro_run ge i m1 old = None <-> exists x, tree_eval (deps_get (macro_deps i d od) x) m0 = None. Proof. intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. - intros H0. - remember (exp_eval e m1 old) as ov. + remember (exp_eval ge e m1 old) as ov. destruct ov. + refine (IHi _ _ _); eauto. intros x0; unfold assign; destruct (R.eq_dec x x0). @@ -272,23 +275,23 @@ Qed. Lemma tree_eval_None_correct p m0: forall m1 d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - run p m1 = None <-> exists x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. + run ge p m1 = None <-> exists x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. Proof. induction p as [|i p IHp]; simpl; intros m1 d. - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. - intros H0. - remember (macro_run i m1 m1) as om. + remember (macro_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _); eauto. + intuition. - assert (X: macro_run i m1 m1 = None); auto. + assert (X: macro_run ge i m1 m1 = None); auto. rewrite tree_eval_macro_None_correct in X; auto. destruct X as [x H1]. constructor 1 with (x:=x); simpl; auto. Qed. Lemma bblock_deps_None_correct p m: - run p m = None <-> exists x, tree_eval (deps_get (bblock_deps p) x) m = None. + run ge p m = None <-> exists x, tree_eval (deps_get (bblock_deps p) x) m = None. Proof. intros; eapply tree_eval_None_correct. intros; autorewrite with dict_rw; simpl; eauto. @@ -299,7 +302,7 @@ Lemma tree_eval_macro_Some_correct2 i m0 old od: forall (m1 m2: mem) d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> (forall x, tree_eval (deps_get (macro_deps i d od) x) m0 = Some (m2 x)) -> - res_eq (Some m2) (macro_run i m1 old). + res_eq (Some m2) (macro_run ge i m1 old). Proof. intro X. induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H0. @@ -307,7 +310,7 @@ Proof. generalize (H0 x); rewrite H. congruence. - intros H. - remember (exp_eval e m1 old) as ov. + remember (exp_eval ge e m1 old) as ov. destruct ov. + refine (IHi _ _ _ _ _); eauto. intros x0; unfold assign; destruct (R.eq_dec x x0). @@ -325,17 +328,17 @@ Qed. Lemma tree_eval_Some_correct2 p m0: forall (m1 m2: mem) d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)) -> - res_eq (Some m2) (run p m1). + res_eq (Some m2) (run ge p m1). Proof. induction p as [|i p]; simpl; intros m1 m2 d H0. - intros H; eapply ex_intro; intuition eauto. generalize (H0 x); rewrite H. congruence. - intros H. - remember (macro_run i m1 m1) as om. + remember (macro_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _ _ _); eauto. - + assert (X: macro_run i m1 m1 = None); auto. + + assert (X: macro_run ge i m1 m1 = None); auto. rewrite tree_eval_macro_None_correct in X; auto. destruct X as [x H1]. generalize (H x). @@ -344,7 +347,7 @@ Qed. Lemma bblock_deps_Some_correct2 p m0 m1: (forall x, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x)) - -> res_eq (Some m1) (run p m0). + -> res_eq (Some m1) (run ge p m0). Proof. intros; eapply tree_eval_Some_correct2; eauto. intros; autorewrite with dict_rw; simpl; eauto. @@ -353,22 +356,24 @@ Qed. Theorem bblock_deps_equiv p1 p2: (forall x, deps_get (bblock_deps p1) x = deps_get (bblock_deps p2) x) - -> bblock_equiv p1 p2. + -> bblock_equiv ge p1 p2. Proof. intros H m2. - remember (run p1 m2) as om1. + remember (run ge p1 m2) as om1. destruct om1; simpl. + apply bblock_deps_Some_correct2. intros; rewrite <- H. apply bblock_deps_Some_correct1; auto. + rewrite bblock_deps_None_correct. - assert (X: run p1 m2 = None); auto. + assert (X: run ge p1 m2 = None); auto. rewrite bblock_deps_None_correct in X. destruct X as [x Hx]. rewrite H in Hx. eauto. Qed. +End DEPTREE. + End DepTree. Require Import PArith. diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 65f12b8e..994c8e34 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -72,6 +72,8 @@ Hypothesis hC_tree_correct: forall t, WHEN hC_tree t ~> t' THEN pre_data t=data 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'. +Variable ge: genv. + (* First, we wrap constructors for hashed values !*) Local Open Scope positive. @@ -213,7 +215,7 @@ Fixpoint hmacro_deps (i: macro) (d od: hdeps): ?? hdeps := | (x, e)::i' => DO dbg <~ debug_assign x;; DO t0 <~ hdeps_get d x None;; - DO v' <~ (if failsafe (data t0) + DO v' <~ (if failsafe ge (data t0) then hexp_tree e d od dbg else @@ -246,20 +248,20 @@ Lemma hmacro_deps_correct i: forall d1 od1, WHEN hmacro_deps i d1 od1 ~> d1' THEN forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> (forall x, pdeps_get d1 x = deps_get d2 x) -> - forall x, pdeps_get d1' x = deps_get (macro_deps i d2 od2) x. + forall x, pdeps_get d1' x = deps_get (macro_deps ge i d2 od2) x. Proof. induction i; simpl; wlp_simplify. - + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). + + cutrewrite (failsafe ge (deps_get d2 a0) = failsafe ge (data exta0)). - erewrite H0, H2; simpl; eauto. clear exta2 Hexta2 H2; auto. intros x0; destruct (R.eq_dec a0 x0). - * subst; autorewrite with dict_rw. erewrite H1; eauto. + * subst. autorewrite with dict_rw. rewrite set_spec_eq. erewrite H1; eauto. * rewrite set_spec_diff, pset_spec_diff; auto. - rewrite H, H4; auto. - + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). + + cutrewrite (failsafe ge (deps_get d2 a0) = failsafe ge (data exta0)). - erewrite H0, H3; simpl; eauto. clear exta3 Hexta3 H3; auto. intros x0; destruct (R.eq_dec a0 x0). * subst; autorewrite with dict_rw. rewrite H2. - erewrite H, H1; eauto. congruence. + erewrite H, H1; eauto. rewrite set_spec_eq. congruence. * rewrite set_spec_diff, pset_spec_diff; auto. - rewrite H, H5; auto. Qed. @@ -280,7 +282,7 @@ Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := Lemma hbblock_deps_rec_correct p: forall d1, WHEN hbblock_deps_rec p d1 ~> d1' THEN - forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec p d2) x. + forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec ge p d2) x. Proof. induction p; simpl; wlp_simplify. Qed. @@ -292,10 +294,10 @@ Definition hbblock_deps: bblock -> ?? hdeps := fun p => hbblock_deps_rec p Dict.empty. Lemma hbblock_deps_correct p: - WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps p) x. + WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps ge p) x. Proof. unfold bblock_deps; wlp_simplify. erewrite H; eauto. - intros; autorewrite with dict_rw; auto. + intros; autorewrite with dict_rw; auto. rewrite empty_spec. reflexivity. Qed. Global Opaque hbblock_deps. @@ -373,7 +375,7 @@ Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 macros *) Variable dbg2: R.t -> ?? option pstring. (* log of p2 macros *) Variable log1: unit -> ?? unit. (* log of p1 macros *) Variable log2: unit -> ?? unit. (* log of p2 macros *) - +Variable ge: genv. Variable hco_tree: hashConsing tree. @@ -386,8 +388,8 @@ Variable print_error: pstring -> ?? unit. Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := 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 d1 <~ hbblock_deps (hC hco_tree) (hC hco_list) ge dbg1 log1 p1 ;; + DO d2 <~ hbblock_deps (hC_known hco_tree) (hC_known hco_list) ge dbg2 log2 p2 ;; DO b <~ Dict.eq_test d1 d2 ;; if b then RET true else ( @@ -397,7 +399,7 @@ Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := CATCH_FAIL s, _ => print_error s;; RET false - ENSURE (fun b => b=true -> bblock_equiv p1 p2));; + ENSURE (fun b => b=true -> bblock_equiv ge p1 p2));; RET (`r). Obligation 1. destruct hco_tree_correct as [X1 X2], hco_list_correct as [Y1 Y2]. @@ -408,7 +410,7 @@ Obligation 1. Qed. Theorem g_bblock_eq_test_correct p1 p2: - WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. + WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. Proof. wlp_simplify. destruct exta; simpl in * |- *; auto. @@ -437,11 +439,11 @@ Definition print_error (log: logger unit) (s:pstring): ?? unit println (msg_prefix +; msg_number +; n +; " -- " +; s). -Program Definition bblock_eq_test (p1 p2: bblock): ?? bool := +Program Definition bblock_eq_test (ge: genv) (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_eq_test no_dbg no_dbg skip (log_insert log) hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. + g_bblock_eq_test no_dbg no_dbg skip (log_insert log) ge hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. Obligation 1. generalize (hCons_correct _ _ _ _ H0); clear H0. constructor 1; wlp_simplify. @@ -453,8 +455,8 @@ Qed. Local Hint Resolve g_bblock_eq_test_correct. -Theorem bblock_eq_test_correct p1 p2: - WHEN bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Theorem bblock_eq_test_correct ge p1 p2: + WHEN bblock_eq_test ge p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. Proof. wlp_simplify. Qed. @@ -688,7 +690,7 @@ Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing lis next_log hcl s ). -Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := +Program Definition verb_bblock_eq_test (ge: genv) (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref Nothing;; @@ -699,6 +701,7 @@ Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := simple_debug (hlog log1 hco_tree hco_list) (log_insert log2) + ge hco_tree _ hco_list _ (print_error_end1 hco_tree hco_list) @@ -717,6 +720,7 @@ Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := simple_debug (hlog log1 hco_tree hco_list) (log_insert log2) + ge hco_tree _ hco_list _ (print_error_end2 hco_tree hco_list) @@ -745,8 +749,8 @@ Obligation 4. constructor 1; wlp_simplify. Qed. -Theorem verb_bblock_eq_test_correct p1 p2: - WHEN verb_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. +Theorem verb_bblock_eq_test_correct ge p1 p2: + WHEN verb_bblock_eq_test ge p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. Proof. wlp_simplify. Qed. diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 6bfd8770..b6d1f142 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -18,12 +18,15 @@ Module ParallelSemantics (L: SeqLanguage). Export L. Local Open Scope list. +Section PARALLEL. +Variable ge: genv. + (* parallel run of a macro *) Fixpoint macro_prun (i: macro) (m tmp old: mem): option mem := match i with | nil => Some m | (x, e)::i' => - match exp_eval e tmp old with + match exp_eval ge e tmp old with | Some v' => macro_prun i' (assign m x v') (assign tmp x v') old | None => None end @@ -31,10 +34,10 @@ Fixpoint macro_prun (i: macro) (m tmp old: mem): option mem := (* [macro_prun] is generalization of [macro_run] *) Lemma macro_run_prun i: forall m old, - macro_run i m old = macro_prun i m m old. + macro_run ge i m old = macro_prun i m m old. Proof. induction i as [|[y e] i']; simpl; auto. - intros m old; destruct (exp_eval e m old); simpl; auto. + intros m old; destruct (exp_eval ge e m old); simpl; auto. Qed. @@ -60,7 +63,7 @@ Lemma macro_prun_equiv i old: forall m1 m2 tmp, res_eq (macro_prun i m1 tmp old) (macro_prun i m2 tmp old). Proof. induction i as [|[x e] i']; simpl; eauto. - intros m1 m2 tmp H; destruct (exp_eval e tmp old); simpl; auto. + intros m1 m2 tmp H; destruct (exp_eval ge e tmp old); simpl; auto. eapply IHi'; unfold assign. intros; destruct (R.eq_dec x x0); auto. Qed. @@ -76,6 +79,7 @@ Proof. + intros H1; rewrite H1; simpl; auto. Qed. +End PARALLEL. End ParallelSemantics. @@ -168,6 +172,8 @@ Module ParallelizablityChecking (L: SeqLanguage). Include ParallelSemantics L. +Section PARALLELI. +Variable ge: genv. (** * Preliminary notions on frames *) @@ -249,22 +255,22 @@ Fixpoint macro_wframe(i:macro): list R.t := end. Lemma macro_wframe_correct i m' old: forall m tmp, - macro_prun i m tmp old = Some m' -> + macro_prun ge i m tmp old = Some m' -> forall x, notIn x (macro_wframe i) -> m' x = m x. Proof. induction i as [|[y e] i']; simpl. - intros m tmp H x H0; inversion_clear H; auto. - - intros m tmp H x (H1 & H2); destruct (exp_eval e tmp old); simpl; try congruence. + - intros m tmp H x (H1 & H2); destruct (exp_eval ge e tmp old); simpl; try congruence. cutrewrite (m x = assign m y v x); eauto. rewrite assign_diff; auto. Qed. Lemma macro_prun_fequiv i old: forall m1 m2 tmp, - frame_eq (fun x => In x (macro_wframe i)) (macro_prun i m1 tmp old) (macro_prun i m2 tmp old). + frame_eq (fun x => In x (macro_wframe i)) (macro_prun ge i m1 tmp old) (macro_prun ge i m2 tmp old). Proof. induction i as [|[y e] i']; simpl. - intros m1 m2 tmp; eexists; intuition eauto. - - intros m1 m2 tmp. destruct (exp_eval e tmp old); simpl; auto. + - intros m1 m2 tmp. destruct (exp_eval ge e tmp old); simpl; auto. eapply frame_eq_list_split; eauto. clear IHi'. intros m1' m2' x H1 H2. lapply (macro_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. @@ -275,16 +281,16 @@ Proof. Qed. Lemma macro_prun_None i m1 m2 tmp old: - macro_prun i m1 tmp old = None -> - macro_prun i m2 tmp old = None. + macro_prun ge i m1 tmp old = None -> + macro_prun ge i m2 tmp old = None. Proof. intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). rewrite H; simpl; auto. Qed. Lemma macro_prun_Some i m1 m2 tmp old m1': - macro_prun i m1 tmp old = Some m1' -> - res_eq (Some (frame_assign m2 (macro_wframe i) m1')) (macro_prun i m2 tmp old). + macro_prun ge i m1 tmp old = Some m1' -> + res_eq (Some (frame_assign m2 (macro_wframe i) m1')) (macro_prun ge i m2 tmp old). Proof. intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). rewrite H; simpl. @@ -385,17 +391,17 @@ Qed. Theorem is_det_correct p p': Permutation p p' -> is_det p -> - forall m old, res_eq (prun_iw p m old) (prun_iw p' m old). + forall m old, res_eq (prun_iw ge p m old) (prun_iw ge p' m old). Proof. induction 1 as [ | i p p' | i1 i2 p | p1 p2 p3 ]; simpl; eauto. - intros [H0 H1] m old. - remember (macro_prun i m old old) as om0. + remember (macro_prun ge i m old old) as om0. destruct om0 as [ m0 | ]; simpl; auto. - rewrite disjoint_app_r. intros ([Z1 Z2] & Z3 & Z4) m old. - remember (macro_prun i2 m old old) as om2. + remember (macro_prun ge i2 m old old) as om2. destruct om2 as [ m2 | ]; simpl; auto. - + remember (macro_prun i1 m old old) as om1. + + remember (macro_prun ge i1 m old old) as om1. destruct om1 as [ m1 | ]; simpl; auto. * lapply (macro_prun_Some i2 m m1 old old m2); simpl; auto. lapply (macro_prun_Some i1 m m2 old old m1); simpl; auto. @@ -412,7 +418,7 @@ Proof. } rewrite frame_assign_notIn; auto. * erewrite macro_prun_None; eauto. simpl; auto. - + remember (macro_prun i1 m old old) as om1. + + remember (macro_prun ge i1 m old old) as om1. destruct om1 as [ m1 | ]; simpl; auto. erewrite macro_prun_None; eauto. - intros; eapply res_eq_trans. @@ -439,10 +445,10 @@ with list_exp_frame (le: list_exp): list R.t := Lemma exp_frame_correct e old1 old2: (forall x, In x (exp_frame e) -> old1 x = old2 x) -> forall m1 m2, (forall x, In x (exp_frame e) -> m1 x = m2 x) -> - (exp_eval e m1 old1)=(exp_eval e m2 old2). + (exp_eval ge e m1 old1)=(exp_eval ge e m2 old2). Proof. induction e using exp_mut with (P0:=fun l => (forall x, In x (list_exp_frame l) -> old1 x = old2 x) -> forall m1 m2, (forall x, In x (list_exp_frame l) -> m1 x = m2 x) -> - (list_exp_eval l m1 old1)=(list_exp_eval l m2 old2)); simpl; auto. + (list_exp_eval ge l m1 old1)=(list_exp_eval ge l m2 old2)); simpl; auto. - intros H1 m1 m2 H2; rewrite H2; auto. - intros H1 m1 m2 H2; erewrite IHe; eauto. - intros H1 m1 m2 H2; erewrite IHe, IHe0; eauto; @@ -465,13 +471,13 @@ Lemma macro_frame_correct i wframe old1 old2: forall m tmp1 tmp2, (disjoint (macro_frame i) wframe) -> (forall x, notIn x wframe -> old1 x = old2 x) -> (forall x, notIn x wframe -> tmp1 x = tmp2 x) -> - macro_prun i m tmp1 old1 = macro_prun i m tmp2 old2. + macro_prun ge i m tmp1 old1 = macro_prun ge i m tmp2 old2. Proof. induction i as [|[x e] i']; simpl; auto. intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. intros (H1 & H2 & H3) H6 H7. - cutrewrite (exp_eval e tmp1 old1 = exp_eval e tmp2 old2). - - destruct (exp_eval e tmp2 old2); auto. + cutrewrite (exp_eval ge e tmp1 old1 = exp_eval ge e tmp2 old2). + - destruct (exp_eval ge e tmp2 old2); auto. eapply IHi'; eauto. simpl; intros x0 H0; unfold assign. destruct (R.eq_dec x x0); simpl; auto. - unfold disjoint in H2; apply exp_frame_correct. @@ -512,12 +518,12 @@ Qed. Lemma pararec_correct p old: forall wframe m, pararec p wframe -> (forall x, notIn x wframe -> m x = old x) -> - run p m = prun_iw p m old. + run ge p m = prun_iw ge p m old. Proof. elim p; clear p; simpl; auto. intros i p' X wframe m [H H0] H1. erewrite macro_run_prun, macro_frame_correct; eauto. - remember (macro_prun i m old old) as om0. + remember (macro_prun ge i m old old) as om0. destruct om0 as [m0 | ]; try congruence. eapply X; eauto. intro x; rewrite notIn_app. intros [H3 H4]. @@ -528,7 +534,7 @@ Qed. Definition parallelizable (p: bblock) := pararec p nil. Theorem parallelizable_correct p m om': - parallelizable p -> (prun p m om' <-> res_eq om' (run p m)). + parallelizable p -> (prun ge p m om' <-> res_eq om' (run ge p m)). Proof. intros H. constructor 1. - intros (p' & H0 & H1). eapply res_eq_trans; eauto. @@ -541,6 +547,8 @@ Proof. erewrite pararec_correct in H0; eauto. Qed. +End PARALLELI. + End ParallelizablityChecking. @@ -585,6 +593,9 @@ Module ParallelChecks (L: SeqLanguage) (S:ResourceSet with Module R:=L.LP.R). 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. (** Now, refinement of each operation toward parallelizable *) @@ -656,12 +667,13 @@ Proof. Qed. Theorem is_parallelizable_correct p: - is_parallelizable p = true -> forall m om', (prun p m om' <-> res_eq om' (run p m)). + is_parallelizable p = true -> forall m om', (prun ge p m om' <-> res_eq om' (run ge p m)). Proof. intros; apply parallelizable_correct. apply is_para_correct_aux. auto. Qed. +End PARALLEL2. End ParallelChecks. -- cgit From e9a863a7c23987aaa51baa9526d4a11aa124462e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Feb 2019 12:01:33 +0100 Subject: WIP sur Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 168 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) create mode 100644 mppa_k1c/Asmblockdeps.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v new file mode 100644 index 00000000..e6990f2c --- /dev/null +++ b/mppa_k1c/Asmblockdeps.v @@ -0,0 +1,168 @@ +Require Import Asmblock. +Require Import Values. +Require Import Globalenvs. +Require Import Memory. +Require Import ImpDep. + + +Module R<: ResourceNames. + +Inductive t_wrap := Reg (r: preg) | Mem. + +Definition t := t_wrap. + +Lemma eq_dec : forall (x y: t), { x = y } + { x<>y }. +Proof. + decide equality. decide equality; apply ireg_eq. +Qed. + +End R. + + +Module P<: ImpParam. + +Module R := R. + +Inductive value_wrap := + | Val (v: val) + | Memstate (m: mem) +. + +Definition value := value_wrap. + +Inductive op_wrap := + | Arith (ai: ar_instruction) + | Load (li: ld_instruction) + | Store (si: st_instruction) +. + +Definition op := op_wrap. + +Definition genv := Genv.t fundef unit. + +Definition arith_eval (ge: genv) (ai: ar_instruction) (l: list value) := + match ai, l with + | PArithR n _, [] => + match n with + | Ploadsymbol s ofs => Some (Genv.symbol_address ge s ofs) + end + + | PArithRR n _ _, [Val v] => + match n with + | Pmv => Some v + | Pnegw => Some (Val.neg v) + | Pnegl => Some (Val.negl v) + | Pcvtl2w => Some (Val.loword v) + | Psxwd => Some (Val.longofint v) + | Pzxwd => Some (Val.longofintu v) + | Pfnegd => Some (Val.negf v) + | Pfnegw => Some (Val.negfs v) + | Pfabsd => Some (Val.absf v) + | Pfabsw => Some (Val.absfs v) + | Pfnarrowdw => Some (Val.singleoffloat v) + | Pfwidenlwd => Some (Val.floatofsingle v) + | Pfloatwrnsz => Some (match Val.singleofint v with Some f => f | _ => Vundef end) + | Pfloatudrnsz => Some (match Val.floatoflongu v with Some f => f | _ => Vundef end) + | Pfloatdrnsz => Some (match Val.floatoflong v with Some f => f | _ => Vundef end) + | Pfixedwrzz => Some (match Val.intofsingle v with Some i => i | _ => Vundef end) + | Pfixeddrzz => Some (match Val.longoffloat v with Some i => i | _ => Vundef end) + end + + | PArithRI32 n _ i, [] => + match n with + | Pmake => Some (Vint i) + end + + | PArithRI64 n _ i, [] => + match n with + | Pmakel => Some (Vlong i) + end + + | PArithRF32 n _ i, [] => + match n with + | Pmakefs => Some (Vsingle i) + end + + | PArithRF64 n _ i, [] => + match n with + | Pmakef => Some (Vfloat i) + end + + | PArithRRR n _ _ _, [Val v1; Val v2; Memstate m] => + match n with + | Pcompw c => Some (compare_int c v1 v2 m) + | Pcompl c => Some (compare_long c v1 v2 m) + | _ => None + end + + | PArithRRR n _ _ _, [Val v1; Val v2] => + match n with + | Paddw => Some (Val.add v1 v2) + | Psubw => Some (Val.sub v1 v2) + | Pmulw => Some (Val.mul v1 v2) + | Pandw => Some (Val.and v1 v2) + | Porw => Some (Val.or v1 v2) + | Pxorw => Some (Val.xor v1 v2) + | Psrlw => Some (Val.shru v1 v2) + | Psraw => Some (Val.shr v1 v2) + | Psllw => Some (Val.shl v1 v2) + + | Paddl => Some (Val.addl v1 v2) + | Psubl => Some (Val.subl v1 v2) + | Pandl => Some (Val.andl v1 v2) + | Porl => Some (Val.orl v1 v2) + | Pxorl => Some (Val.xorl v1 v2) + | Pmull => Some (Val.mull v1 v2) + | Pslll => Some (Val.shll v1 v2) + | Psrll => Some (Val.shrlu v1 v2) + | Psral => Some (Val.shrl v1 v2) + + | Pfaddd => Some (Val.addf v1 v2) + | Pfaddw => Some (Val.addfs v1 v2) + | Pfsbfd => Some (Val.subf v1 v2) + | Pfsbfw => Some (Val.subfs v1 v2) + | Pfmuld => Some (Val.mulf v1 v2) + | Pfmulw => Some (Val.mulfs v1 v2) + + | _ => None + end + + | PArithRRI32 n _ _ i, [Val v; Memstate m] => + match n with + | Pcompiw c => Some (compare_int c v (Vint i) m) + | _ => None + end + + | PArithRRI32 n _ _ i, [Val v] => + match n with + | Paddiw => Some (Val.add v (Vint i)) + | Pandiw => Some (Val.and v (Vint i)) + | Poriw => Some (Val.or v (Vint i)) + | Pxoriw => Some (Val.xor v (Vint i)) + | Psraiw => Some (Val.shr v (Vint i)) + | Psrliw => Some (Val.shru v (Vint i)) + | Pslliw => Some (Val.shl v (Vint i)) + | Psllil => Some (Val.shll v (Vint i)) + | Psrlil => Some (Val.shrlu v (Vint i)) + | Psrail => Some (Val.shrl v (Vint i)) + | _ => None + end + + | PArithRRI64 n d s i => + match n with + | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m) + | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) + | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) + | Poril => rs#d <- (Val.orl rs#s (Vlong i)) + | Pxoril => rs#d <- (Val.xorl rs#s (Vlong i)) + end + end + +Definition op_eval (ge: genv) (o: op) (l: list value) := + match o with + | Arith i => arith_eval ge i l + | Load i => load_eval ge i l + | Store i => store_eval ge i l + end. + +End P. -- cgit From 85a1ba2509741be87511ec5abf7757f92a068c74 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Feb 2019 16:24:28 +0100 Subject: Finished specialization of the Abstractbb language --- mppa_k1c/Asmblockdeps.v | 342 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 253 insertions(+), 89 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e6990f2c..6cd66ea3 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,9 +1,14 @@ +Require Import AST. Require Import Asmblock. Require Import Values. Require Import Globalenvs. Require Import Memory. +Require Import Errors. +Require Import Integers. +Require Import Floats. Require Import ImpDep. +Open Scope impure. Module R<: ResourceNames. @@ -20,9 +25,13 @@ End R. Module P<: ImpParam. - Module R := R. +Section IMPPARAM. + +Definition genv := Genv.t fundef unit. +Variable ge: genv. + Inductive value_wrap := | Val (v: val) | Memstate (m: mem) @@ -30,139 +39,294 @@ Inductive value_wrap := Definition value := value_wrap. +Inductive arith_op := + | OArithR (n: arith_name_r) + | OArithRR (n: arith_name_rr) + | OArithRI32 (n: arith_name_ri32) (imm: int) + | OArithRI64 (n: arith_name_ri64) (imm: int64) + | OArithRF32 (n: arith_name_rf32) (imm: float32) + | OArithRF64 (n: arith_name_rf64) (imm: float) + | OArithRRR (n: arith_name_rrr) + | OArithRRI32 (n: arith_name_rri32) (imm: int) + | OArithRRI64 (n: arith_name_rri64) (imm: int64) +. + +Inductive load_op := + | OLoadRRO (n: load_name_rro) (ofs: offset) +. + +Inductive store_op := + | OStoreRRO (n: store_name_rro) (ofs: offset) +. + Inductive op_wrap := - | Arith (ai: ar_instruction) - | Load (li: ld_instruction) - | Store (si: st_instruction) + | Arith (ao: arith_op) + | Load (lo: load_op) + | Store (so: store_op) . Definition op := op_wrap. -Definition genv := Genv.t fundef unit. +Definition arith_eval (ao: arith_op) (l: list value) := + match ao, l with + | OArithR n, [] => + match n with + | Ploadsymbol s ofs => Some (Val (Genv.symbol_address ge s ofs)) + end -Definition arith_eval (ge: genv) (ai: ar_instruction) (l: list value) := - match ai, l with - | PArithR n _, [] => + | OArithRR n, [Val v] => match n with - | Ploadsymbol s ofs => Some (Genv.symbol_address ge s ofs) + | Pmv => Some (Val v) + | Pnegw => Some (Val (Val.neg v)) + | Pnegl => Some (Val (Val.negl v)) + | Pcvtl2w => Some (Val (Val.loword v)) + | Psxwd => Some (Val (Val.longofint v)) + | Pzxwd => Some (Val (Val.longofintu v)) + | Pfnegd => Some (Val (Val.negf v)) + | Pfnegw => Some (Val (Val.negfs v)) + | Pfabsd => Some (Val (Val.absf v)) + | Pfabsw => Some (Val (Val.absfs v)) + | Pfnarrowdw => Some (Val (Val.singleoffloat v)) + | Pfwidenlwd => Some (Val (Val.floatofsingle v)) + | Pfloatwrnsz => Some (Val (match Val.singleofint v with Some f => f | _ => Vundef end)) + | Pfloatudrnsz => Some (Val (match Val.floatoflongu v with Some f => f | _ => Vundef end)) + | Pfloatdrnsz => Some (Val (match Val.floatoflong v with Some f => f | _ => Vundef end)) + | Pfixedwrzz => Some (Val (match Val.intofsingle v with Some i => i | _ => Vundef end)) + | Pfixeddrzz => Some (Val (match Val.longoffloat v with Some i => i | _ => Vundef end)) end - | PArithRR n _ _, [Val v] => + | OArithRI32 n i, [] => match n with - | Pmv => Some v - | Pnegw => Some (Val.neg v) - | Pnegl => Some (Val.negl v) - | Pcvtl2w => Some (Val.loword v) - | Psxwd => Some (Val.longofint v) - | Pzxwd => Some (Val.longofintu v) - | Pfnegd => Some (Val.negf v) - | Pfnegw => Some (Val.negfs v) - | Pfabsd => Some (Val.absf v) - | Pfabsw => Some (Val.absfs v) - | Pfnarrowdw => Some (Val.singleoffloat v) - | Pfwidenlwd => Some (Val.floatofsingle v) - | Pfloatwrnsz => Some (match Val.singleofint v with Some f => f | _ => Vundef end) - | Pfloatudrnsz => Some (match Val.floatoflongu v with Some f => f | _ => Vundef end) - | Pfloatdrnsz => Some (match Val.floatoflong v with Some f => f | _ => Vundef end) - | Pfixedwrzz => Some (match Val.intofsingle v with Some i => i | _ => Vundef end) - | Pfixeddrzz => Some (match Val.longoffloat v with Some i => i | _ => Vundef end) + | Pmake => Some (Val (Vint i)) end - | PArithRI32 n _ i, [] => + | OArithRI64 n i, [] => match n with - | Pmake => Some (Vint i) + | Pmakel => Some (Val (Vlong i)) end - | PArithRI64 n _ i, [] => + | OArithRF32 n i, [] => match n with - | Pmakel => Some (Vlong i) + | Pmakefs => Some (Val (Vsingle i)) end - | PArithRF32 n _ i, [] => + | OArithRF64 n i, [] => match n with - | Pmakefs => Some (Vsingle i) + | Pmakef => Some (Val (Vfloat i)) end - | PArithRF64 n _ i, [] => + | OArithRRR n, [Val v1; Val v2; Memstate m] => match n with - | Pmakef => Some (Vfloat i) + | Pcompw c => Some (Val (compare_int c v1 v2 m)) + | Pcompl c => Some (Val (compare_long c v1 v2 m)) + | _ => None end - | PArithRRR n _ _ _, [Val v1; Val v2; Memstate m] => + | OArithRRR n, [Val v1; Val v2] => match n with - | Pcompw c => Some (compare_int c v1 v2 m) - | Pcompl c => Some (compare_long c v1 v2 m) + | Paddw => Some (Val (Val.add v1 v2)) + | Psubw => Some (Val (Val.sub v1 v2)) + | Pmulw => Some (Val (Val.mul v1 v2)) + | Pandw => Some (Val (Val.and v1 v2)) + | Porw => Some (Val (Val.or v1 v2)) + | Pxorw => Some (Val (Val.xor v1 v2)) + | Psrlw => Some (Val (Val.shru v1 v2)) + | Psraw => Some (Val (Val.shr v1 v2)) + | Psllw => Some (Val (Val.shl v1 v2)) + + | Paddl => Some (Val (Val.addl v1 v2)) + | Psubl => Some (Val (Val.subl v1 v2)) + | Pandl => Some (Val (Val.andl v1 v2)) + | Porl => Some (Val (Val.orl v1 v2)) + | Pxorl => Some (Val (Val.xorl v1 v2)) + | Pmull => Some (Val (Val.mull v1 v2)) + | Pslll => Some (Val (Val.shll v1 v2)) + | Psrll => Some (Val (Val.shrlu v1 v2)) + | Psral => Some (Val (Val.shrl v1 v2)) + + | Pfaddd => Some (Val (Val.addf v1 v2)) + | Pfaddw => Some (Val (Val.addfs v1 v2)) + | Pfsbfd => Some (Val (Val.subf v1 v2)) + | Pfsbfw => Some (Val (Val.subfs v1 v2)) + | Pfmuld => Some (Val (Val.mulf v1 v2)) + | Pfmulw => Some (Val (Val.mulfs v1 v2)) + | _ => None end - | PArithRRR n _ _ _, [Val v1; Val v2] => + | OArithRRI32 n i, [Val v; Memstate m] => match n with - | Paddw => Some (Val.add v1 v2) - | Psubw => Some (Val.sub v1 v2) - | Pmulw => Some (Val.mul v1 v2) - | Pandw => Some (Val.and v1 v2) - | Porw => Some (Val.or v1 v2) - | Pxorw => Some (Val.xor v1 v2) - | Psrlw => Some (Val.shru v1 v2) - | Psraw => Some (Val.shr v1 v2) - | Psllw => Some (Val.shl v1 v2) - - | Paddl => Some (Val.addl v1 v2) - | Psubl => Some (Val.subl v1 v2) - | Pandl => Some (Val.andl v1 v2) - | Porl => Some (Val.orl v1 v2) - | Pxorl => Some (Val.xorl v1 v2) - | Pmull => Some (Val.mull v1 v2) - | Pslll => Some (Val.shll v1 v2) - | Psrll => Some (Val.shrlu v1 v2) - | Psral => Some (Val.shrl v1 v2) - - | Pfaddd => Some (Val.addf v1 v2) - | Pfaddw => Some (Val.addfs v1 v2) - | Pfsbfd => Some (Val.subf v1 v2) - | Pfsbfw => Some (Val.subfs v1 v2) - | Pfmuld => Some (Val.mulf v1 v2) - | Pfmulw => Some (Val.mulfs v1 v2) + | Pcompiw c => Some (Val (compare_int c v (Vint i) m)) + | _ => None + end + | OArithRRI32 n i, [Val v] => + match n with + | Paddiw => Some (Val (Val.add v (Vint i))) + | Pandiw => Some (Val (Val.and v (Vint i))) + | Poriw => Some (Val (Val.or v (Vint i))) + | Pxoriw => Some (Val (Val.xor v (Vint i))) + | Psraiw => Some (Val (Val.shr v (Vint i))) + | Psrliw => Some (Val (Val.shru v (Vint i))) + | Pslliw => Some (Val (Val.shl v (Vint i))) + | Psllil => Some (Val (Val.shll v (Vint i))) + | Psrlil => Some (Val (Val.shrlu v (Vint i))) + | Psrail => Some (Val (Val.shrl v (Vint i))) | _ => None end - | PArithRRI32 n _ _ i, [Val v; Memstate m] => + | OArithRRI64 n i, [Val v; Memstate m] => match n with - | Pcompiw c => Some (compare_int c v (Vint i) m) + | Pcompil c => Some (Val (compare_long c v (Vlong i) m)) | _ => None end - | PArithRRI32 n _ _ i, [Val v] => + | OArithRRI64 n i, [Val v] => match n with - | Paddiw => Some (Val.add v (Vint i)) - | Pandiw => Some (Val.and v (Vint i)) - | Poriw => Some (Val.or v (Vint i)) - | Pxoriw => Some (Val.xor v (Vint i)) - | Psraiw => Some (Val.shr v (Vint i)) - | Psrliw => Some (Val.shru v (Vint i)) - | Pslliw => Some (Val.shl v (Vint i)) - | Psllil => Some (Val.shll v (Vint i)) - | Psrlil => Some (Val.shrlu v (Vint i)) - | Psrail => Some (Val.shrl v (Vint i)) + | Paddil => Some (Val (Val.addl v (Vlong i))) + | Pandil => Some (Val (Val.andl v (Vlong i))) + | Poril => Some (Val (Val.orl v (Vlong i))) + | Pxoril => Some (Val (Val.xorl v (Vlong i))) | _ => None end - | PArithRRI64 n d s i => + | _, _ => None + end. + +Definition exec_load_deps (chunk: memory_chunk) (m: mem) + (v: val) (ofs: offset) := + match (eval_offset ge ofs) with + | OK ptr => + match Mem.loadv chunk m (Val.offset_ptr v ptr) with + | None => None + | Some vl => Some (Val vl) + end + | _ => None + end. + +Definition load_eval (lo: load_op) (l: list value) := + match lo, l with + | OLoadRRO n ofs, [Val v; Memstate m] => + match n with + | Plb => exec_load_deps Mint8signed m v ofs + | Plbu => exec_load_deps Mint8unsigned m v ofs + | Plh => exec_load_deps Mint16signed m v ofs + | Plhu => exec_load_deps Mint16unsigned m v ofs + | Plw => exec_load_deps Mint32 m v ofs + | Plw_a => exec_load_deps Many32 m v ofs + | Pld => exec_load_deps Mint64 m v ofs + | Pld_a => exec_load_deps Many64 m v ofs + | Pfls => exec_load_deps Mfloat32 m v ofs + | Pfld => exec_load_deps Mfloat64 m v ofs + end + | _, _ => None + end. + +Definition exec_store_deps (chunk: memory_chunk) (m: mem) + (vs va: val) (ofs: offset) := + match (eval_offset ge ofs) with + | OK ptr => + match Mem.storev chunk m (Val.offset_ptr va ptr) vs with + | None => None + | Some m' => Some (Memstate m') + end + | _ => None + end. + +Definition store_eval (so: store_op) (l: list value) := + match so, l with + | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => match n with - | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m) - | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) - | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) - | Poril => rs#d <- (Val.orl rs#s (Vlong i)) - | Pxoril => rs#d <- (Val.xorl rs#s (Vlong i)) + | Psb => exec_store_deps Mint8unsigned m vs va ofs + | Psh => exec_store_deps Mint16unsigned m vs va ofs + | Psw => exec_store_deps Mint32 m vs va ofs + | Psw_a => exec_store_deps Many32 m vs va ofs + | Psd => exec_store_deps Mint64 m vs va ofs + | Psd_a => exec_store_deps Many64 m vs va ofs + | Pfss => exec_store_deps Mfloat32 m vs va ofs + | Pfsd => exec_store_deps Mfloat64 m vs va ofs end - end + | _, _ => None + end. -Definition op_eval (ge: genv) (o: op) (l: list value) := +Definition op_eval (o: op) (l: list value) := match o with - | Arith i => arith_eval ge i l - | Load i => load_eval ge i l - | Store i => store_eval ge i l + | Arith o => arith_eval o l + | Load o => load_eval o l + | Store o => store_eval o l + end. + +Definition iandb (ib1 ib2: ?? bool): ?? bool := + DO b1 <~ ib1;; + DO b2 <~ ib2;; + RET (andb b1 b2). + +Definition arith_op_eq (o1 o2: arith_op): ?? bool := + match o1, o2 with + | OArithR n1, OArithR n2 => phys_eq n1 n2 + | OArithRR n1, OArithRR n2 => phys_eq n1 n2 + | OArithRI32 n1 i1, OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithRI64 n1 i1, OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithRF32 n1 i1, OArithRF32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithRF64 n1 i1, OArithRF64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithRRR n1, OArithRRR n2 => phys_eq n1 n2 + | OArithRRI32 n1 i1, OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithRRI64 n1 i1, OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | _, _ => RET false + end. + +Lemma arith_op_eq_correct o1 o2: + WHEN arith_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; try discriminate. + all: try congruence. + all: apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. +Qed. + + +Definition load_op_eq (o1 o2: load_op): ?? bool := + match o1, o2 with + | OLoadRRO n1 ofs1, OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) + 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. + apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. +Qed. + + +Definition store_op_eq (o1 o2: store_op): ?? bool := + match o1, o2 with + | OStoreRRO n1 ofs1, OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) + end. + +Lemma store_op_eq_correct o1 o2: + WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify. + apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. +Qed. + + +Definition op_eq (o1 o2: op): ?? bool := + match o1, o2 with + | Arith i1, Arith i2 => arith_op_eq i1 i2 + | Load i1, Load i2 => load_op_eq i1 i2 + | Store i1, Store i2 => store_op_eq i1 i2 + | _, _ => RET false end. +Theorem op_eq_correct o1 o2: + WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; try discriminate. + - simpl in Hexta. exploit arith_op_eq_correct. eassumption. eauto. congruence. + - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. + - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. +Qed. + + +End IMPPARAM. End P. -- cgit From 06e0295e4b6289a33d456e1b93dea615b65dc755 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Feb 2019 16:28:35 +0100 Subject: Stuck at module IDT --- mppa_k1c/Asmblockdeps.v | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6cd66ea3..54258882 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -327,6 +327,15 @@ Proof. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. Qed. - End IMPPARAM. End P. + +Module L <: ISeqLanguage with Module LP:=P. + +Module LP:=P. + +Include MkSeqLanguage P. + +End L. + +Module IDT := ImpDepTree L ImpPosDict. -- cgit From f6473ff0069aa6493d6c52a5dd05b460269236e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Feb 2019 16:46:26 +0100 Subject: Problème résolu en prenant les noms de resources comme étant des Pos MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockdeps.v | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 54258882..934e7d83 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -6,11 +6,13 @@ Require Import Memory. Require Import Errors. Require Import Integers. Require Import Floats. +Require Import ZArith. Require Import ImpDep. Open Scope impure. -Module R<: ResourceNames. +(* FIXME - incompatible with IDP (not without additional code) so commenting it out *) +(* Module R<: ResourceNames. Inductive t_wrap := Reg (r: preg) | Mem. @@ -21,11 +23,10 @@ Proof. decide equality. decide equality; apply ireg_eq. Qed. -End R. - +End R. *) Module P<: ImpParam. -Module R := R. +Module R := Pos. Section IMPPARAM. @@ -339,3 +340,12 @@ Include MkSeqLanguage P. End L. Module IDT := ImpDepTree L ImpPosDict. + +Section SECT. +Variable ge: P.genv. + +(** Compilation from Asmblock to L *) + +(* TODO - d'abord, raffiner le modèle dans PostpassScheduling.v pour extraire le exit (n'envoyer que le body à la vérif) *) + +End SECT. -- cgit From a17303a44371cd867a4df647bf566f4a101bf5aa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Feb 2019 14:43:21 +0100 Subject: Added useful operators for the control flow instructions --- mppa_k1c/Asmblockdeps.v | 77 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 74 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 934e7d83..6f5b4c1f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -30,8 +30,12 @@ Module R := Pos. Section IMPPARAM. -Definition genv := Genv.t fundef unit. -Variable ge: genv. +Definition env := Genv.t fundef unit. + +Inductive genv_wrap := Genv (ge: env) (fn: function). +Definition genv := genv_wrap. + +Variable GE: genv. Inductive value_wrap := | Val (v: val) @@ -40,6 +44,12 @@ Inductive value_wrap := Definition value := value_wrap. +Inductive control_op := + | Oj_l (l: label) + | Ocb (bt: btest) (l: label) + | Ocbu (bt: btest) (l: label) +. + Inductive arith_op := | OArithR (n: arith_name_r) | OArithRR (n: arith_name_rr) @@ -64,11 +74,13 @@ Inductive op_wrap := | Arith (ao: arith_op) | Load (lo: load_op) | Store (so: store_op) + | Control (co: control_op) . Definition op := op_wrap. Definition arith_eval (ao: arith_op) (l: list value) := + let (ge, fn) := GE in match ao, l with | OArithR n, [] => match n with @@ -196,6 +208,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := Definition exec_load_deps (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := + let (ge, fn) := GE in match (eval_offset ge ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with @@ -225,6 +238,7 @@ Definition load_eval (lo: load_op) (l: list value) := Definition exec_store_deps (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := + let (ge, fn) := GE in match (eval_offset ge ofs) with | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with @@ -250,11 +264,48 @@ Definition store_eval (so: store_op) (l: list value) := | _, _ => None end. +Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := + match label_pos lbl 0 (fn_blocks f) with + | None => None + | Some pos => + match vpc with + | Vptr b ofs => Some (Val (Vptr b (Ptrofs.repr pos))) + | _ => None + end + end. + +Definition eval_branch_deps (f: function) (l: label) (vpc: val) (res: option bool) := + match res with + | Some true => goto_label_deps f l vpc + | Some false => Some (Val vpc) + | None => None + end. + +Definition control_eval (o: control_op) (l: list value) := + let (ge, fn) := GE in + match o, l with + | Oj_l l, [Val vpc] => goto_label_deps fn l vpc + | Ocb bt l, [Val v; Val vpc] => + match cmp_for_btest bt with + | (Some c, Int) => eval_branch_deps fn l vpc (Val.cmp_bool c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmpl_bool c v (Vlong (Int64.repr 0))) + | (None, _) => None + end + | Ocbu bt l, [Val v; Val vpc; Memstate m] => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch_deps fn l vpc (Val.cmpu_bool (Mem.valid_pointer m) c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong (Int64.repr 0))) + | (None, _) => None + end + | _, _ => None + end. + Definition op_eval (o: op) (l: list value) := match o with | Arith o => arith_eval o l | Load o => load_eval o l | Store o => store_eval o l + | Control o => control_eval o l end. Definition iandb (ib1 ib2: ?? bool): ?? bool := @@ -311,11 +362,30 @@ Proof. Qed. +Definition control_op_eq (c1 c2: control_op): ?? bool := + match c1, c2 with + | Oj_l l1, Oj_l l2 => phys_eq l1 l2 + | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) + | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) + | _, _ => RET false + end. + +Lemma control_op_eq_correct c1 c2: + WHEN control_op_eq c1 c2 ~> b THEN b = true -> c1 = c2. +Proof. + destruct c1, c2; wlp_simplify; try discriminate. + - congruence. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. +Qed. + + Definition op_eq (o1 o2: op): ?? bool := match o1, o2 with | Arith i1, Arith i2 => arith_op_eq i1 i2 | Load i1, Load i2 => load_op_eq i1 i2 | Store i1, Store i2 => store_op_eq i1 i2 + | Control i1, Control i2 => control_op_eq i1 i2 | _, _ => RET false end. @@ -326,6 +396,7 @@ Proof. - simpl in Hexta. exploit arith_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. + - simpl in Hexta. exploit control_op_eq_correct. eassumption. eauto. congruence. Qed. End IMPPARAM. @@ -342,7 +413,7 @@ End L. Module IDT := ImpDepTree L ImpPosDict. Section SECT. -Variable ge: P.genv. +Variable GE: P.genv. (** Compilation from Asmblock to L *) -- cgit From 20cb5c46636c5a855efd49ea6459af12211d7bd0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Feb 2019 15:04:15 +0100 Subject: Remove unnecessary and error prone FR constructor for pregs --- mppa_k1c/Asmblock.v | 7 ++----- mppa_k1c/Asmblockgenproof.v | 6 +++--- mppa_k1c/Asmexpand.ml | 1 - mppa_k1c/TargetPrinter.ml | 2 -- 4 files changed, 5 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index a582e866..b9c50517 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -65,17 +65,15 @@ Proof. decide equality. Defined. (** basic register *) Inductive preg: Type := - | IR: gpreg -> preg (**r integer registers *) - | FR: gpreg -> preg (**r float registers *) + | IR: gpreg -> preg (**r integer general purpose registers *) | RA: preg | PC: preg . Coercion IR: gpreg >-> preg. -Coercion FR: gpreg >-> preg. Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. +Proof. decide equality. apply ireg_eq. Defined. Module PregEq. Definition t := preg. @@ -1436,7 +1434,6 @@ Definition data_preg (r: preg) : bool := | IR GPRA => false | IR RTMP => false | IR _ => true - | FR _ => true | PC => false end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 14a84b6a..9cba8402 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1076,8 +1076,8 @@ Lemma nextblock_preserves: rs r = rs' r. Proof. intros. destruct r; try discriminate. - - subst. Simpl. - - subst. Simpl. + subst. Simpl. +(* - subst. Simpl. *) Qed. Lemma cons3_app {A: Type}: @@ -1274,7 +1274,7 @@ Proof. 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. +(* - destruct g. all: rewrite INV; Simpl; auto. *) - rewrite INV; Simpl; auto. - contradiction. } eauto with asmgen. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 59e8c383..cf06ebaf 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -519,7 +519,6 @@ let int_reg_to_dwarf = let open Asmblock in function let preg_to_dwarf = let open Asmblock in function | IR r -> int_reg_to_dwarf r - | FR r -> int_reg_to_dwarf r | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) | _ -> assert false diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index da3cf75f..bbb608de 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -64,13 +64,11 @@ module Target (*: TARGET*) = let preg oc = let open Asmblock in function | IR r -> ireg oc r - | FR r -> ireg oc r | RA -> output_string oc "$ra" | _ -> assert false let preg_annot = let open Asmblock in function | IR r -> int_reg_name r - | FR r -> int_reg_name r | RA -> "$ra" | _ -> assert false -- cgit From e4269e2e9db4575d257bb21eeca326336eebc1de Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Feb 2019 16:11:17 +0100 Subject: Added compilation of control instructions to AbstractBB --- mppa_k1c/Asmblockdeps.v | 77 +++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 74 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6f5b4c1f..5cda4db2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -62,14 +62,28 @@ Inductive arith_op := | OArithRRI64 (n: arith_name_rri64) (imm: int64) . +Coercion OArithR: arith_name_r >-> arith_op. +Coercion OArithRR: arith_name_rr >-> arith_op. +Coercion OArithRI32: arith_name_ri32 >-> Funclass. +Coercion OArithRI64: arith_name_ri64 >-> Funclass. +Coercion OArithRF32: arith_name_rf32 >-> Funclass. +Coercion OArithRF64: arith_name_rf64 >-> Funclass. +Coercion OArithRRR: arith_name_rrr >-> arith_op. +Coercion OArithRRI32: arith_name_rri32 >-> Funclass. +Coercion OArithRRI64: arith_name_rri64 >-> Funclass. + Inductive load_op := | OLoadRRO (n: load_name_rro) (ofs: offset) . +Coercion OLoadRRO: load_name_rro >-> Funclass. + Inductive store_op := | OStoreRRO (n: store_name_rro) (ofs: offset) . +Coercion OStoreRRO: store_name_rro >-> Funclass. + Inductive op_wrap := | Arith (ao: arith_op) | Load (lo: load_op) @@ -77,6 +91,11 @@ Inductive op_wrap := | Control (co: control_op) . +Coercion Arith: arith_op >-> op_wrap. +Coercion Load: load_op >-> op_wrap. +Coercion Store: store_op >-> op_wrap. +Coercion Control: control_op >-> op_wrap. + Definition op := op_wrap. Definition arith_eval (ao: arith_op) (l: list value) := @@ -412,11 +431,63 @@ End L. Module IDT := ImpDepTree L ImpPosDict. -Section SECT. -Variable GE: P.genv. +Import L. +Import P. (** Compilation from Asmblock to L *) -(* TODO - d'abord, raffiner le modèle dans PostpassScheduling.v pour extraire le exit (n'envoyer que le body à la vérif) *) +Section SECT. +Variable GE: genv. + +Definition pmem : R.t := 1. + +Definition ireg_to_pos (ir: ireg) : R.t := + match ir with + | GPR0 => 1 | GPR1 => 2 | GPR2 => 3 | GPR3 => 4 | GPR4 => 5 | GPR5 => 6 | GPR6 => 7 | GPR7 => 8 | GPR8 => 9 | GPR9 => 10 + | GPR10 => 11 | GPR11 => 12 | GPR12 => 13 | GPR13 => 14 | GPR14 => 15 | GPR15 => 16 | GPR16 => 17 | GPR17 => 18 | GPR18 => 19 | GPR19 => 20 + | GPR20 => 21 | GPR21 => 22 | GPR22 => 23 | GPR23 => 24 | GPR24 => 25 | GPR25 => 26 | GPR26 => 27 | GPR27 => 28 | GPR28 => 29 | GPR29 => 30 + | GPR30 => 31 | GPR31 => 32 | GPR32 => 33 | GPR33 => 34 | GPR34 => 35 | GPR35 => 36 | GPR36 => 37 | GPR37 => 38 | GPR38 => 39 | GPR39 => 40 + | GPR40 => 41 | GPR41 => 42 | GPR42 => 43 | GPR43 => 44 | GPR44 => 45 | GPR45 => 46 | GPR46 => 47 | GPR47 => 48 | GPR48 => 49 | GPR49 => 50 + | GPR50 => 51 | GPR51 => 52 | GPR52 => 53 | GPR53 => 54 | GPR54 => 55 | GPR55 => 56 | GPR56 => 57 | GPR57 => 58 | GPR58 => 59 | GPR59 => 60 + | GPR60 => 61 | GPR61 => 62 | GPR62 => 63 | GPR63 => 64 + end +. + +Definition ppos (r: preg) : R.t := + match r with + | RA => 2 + | PC => 3 + | IR ir => 3 + ireg_to_pos ir + end +. + +Notation "# r" := (ppos r) (at level 100, right associativity). + +Notation "a @ b" := (Econs a b) (at level 102, right associativity). + +Definition trans_control (ctl: control) : macro := + match ctl with + | Pret => [(#PC, Name (#RA))] + | Pcall s => [(#RA, Name (#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] + | Picall r => [(#RA, Name (#PC)); (#PC, Name (#r))] + | Pgoto s => [(#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] + | Pigoto r => [(#PC, Name (#r))] + | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] + | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] + | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Name pmem @ Enil))] + | _ => nil + end. + +Definition trans_exit (ex: option control) : list L.macro := + match ex with + | None => nil + | Some ctl => trans_control ctl :: nil + end +. + +(* Definition trans_block (b: bblock) : L.bblock := + trans_body (body b) ++ trans_exit (exit b). +. + *) End SECT. -- cgit From 3e29c4e58853653bf1f3bd374157147d1e1cd75b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Feb 2019 17:15:50 +0100 Subject: Added compilation in abstractbb of most of the basic instructions --- mppa_k1c/Asmblockdeps.v | 82 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 76 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 5cda4db2..41c87441 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -89,6 +89,8 @@ Inductive op_wrap := | Load (lo: load_op) | Store (so: store_op) | Control (co: control_op) + | Allocframe (sz: Z) (pos: ptrofs) + | Constant (v: val) . Coercion Arith: arith_op >-> op_wrap. @@ -320,11 +322,20 @@ Definition control_eval (o: control_op) (l: list value) := end. Definition op_eval (o: op) (l: list value) := - match o with - | Arith o => arith_eval o l - | Load o => load_eval o l - | Store o => store_eval o l - | Control o => control_eval o l + match o, l with + | Arith o, l => arith_eval o l + | Load o, l => load_eval o l + | Store o, l => store_eval o l + | Control o, l => control_eval o l + | Allocframe sz pos, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with + | None => None + | Some m => Some (Memstate m) + end + | Constant v, [] => Some (Val v) + | _, _ => None end. Definition iandb (ib1 ib2: ?? bool): ?? bool := @@ -405,6 +416,7 @@ Definition op_eq (o1 o2: op): ?? bool := | Load i1, Load i2 => load_op_eq i1 i2 | Store i1, Store i2 => store_op_eq i1 i2 | Control i1, Control i2 => control_op_eq i1 i2 + | Allocframe sz1 pos1, Allocframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) | _, _ => RET false end. @@ -416,6 +428,7 @@ Proof. - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit control_op_eq_correct. eassumption. eauto. congruence. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. Qed. End IMPPARAM. @@ -443,7 +456,7 @@ Definition pmem : R.t := 1. Definition ireg_to_pos (ir: ireg) : R.t := match ir with - | GPR0 => 1 | GPR1 => 2 | GPR2 => 3 | GPR3 => 4 | GPR4 => 5 | GPR5 => 6 | GPR6 => 7 | GPR7 => 8 | GPR8 => 9 | GPR9 => 10 + | GPR0 => 1 | GPR1 => 2 | GPR2 => 3 | GPR3 => 4 | GPR4 => 5 | GPR5 => 6 | GPR6 => 7 | GPR7 => 8 | GPR8 => 9 | GPR9 => 10 | GPR10 => 11 | GPR11 => 12 | GPR12 => 13 | GPR13 => 14 | GPR14 => 15 | GPR15 => 16 | GPR16 => 17 | GPR17 => 18 | GPR18 => 19 | GPR19 => 20 | GPR20 => 21 | GPR21 => 22 | GPR22 => 23 | GPR23 => 24 | GPR24 => 25 | GPR25 => 26 | GPR26 => 27 | GPR27 => 28 | GPR28 => 29 | GPR29 => 30 | GPR30 => 31 | GPR31 => 32 | GPR32 => 33 | GPR33 => 34 | GPR34 => 35 | GPR35 => 36 | GPR36 => 37 | GPR37 => 38 | GPR38 => 39 | GPR39 => 40 @@ -485,6 +498,63 @@ Definition trans_exit (ex: option control) : list L.macro := end . +Definition trans_arith (ai: ar_instruction) : macro := + match ai with + | PArithR n d => [(#d, Op (Arith (OArithR n)) Enil)] + | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (Name (#s) @ Enil))] + | PArithRI32 n d i => [(#d, Op (Arith (OArithRI32 n i)) Enil)] + | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] + | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] + | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] + | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] + | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] + | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] + end. + + +Definition trans_basic (b: basic) : macro := + match b with + | PArith ai => trans_arith ai + | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (Name (#a) @ Name pmem @ Enil))] + | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (Name (#s) @ Name (#a) @ Name pmem @ Enil))] + | Pallocframe sz pos => [(pmem, Op (Allocframe sz pos) (Name (#SP) @ Name pmem @ Enil)); + (#FP, Name (#SP)); (#SP, Name (#RTMP)); (#RTMP, Op (Constant Vundef) Enil)] + | _ => [] + end. + +(* + | Pfreeframe sz pos => + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (rs#SP <- v #RTMP <- Vundef) m' + end + | _ => Stuck + end + end + | Pget rd ra => + match ra with + | RA => Next (rs#rd <- (rs#ra)) m + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rs#ra <- (rs#rd)) m + | _ => Stuck + end + | Pnop => Next rs m + end. *) + +Fixpoint trans_body (b: list basic) : list L.macro := + match b with + | nil => nil + | b :: lb => (trans_basic b) :: (trans_body lb) + end. + (* Definition trans_block (b: bblock) : L.bblock := trans_body (body b) ++ trans_exit (exit b). . -- cgit From 04fa6896dfdf8c63be9adaec99091a2061c027b4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Feb 2019 17:39:52 +0100 Subject: Finished the compilation of Asmblock to Abstractbb --- mppa_k1c/Asmblockdeps.v | 72 ++++++++++++++++++++++++++++--------------------- 1 file changed, 41 insertions(+), 31 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 41c87441..bb107574 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -90,6 +90,8 @@ Inductive op_wrap := | Store (so: store_op) | Control (co: control_op) | Allocframe (sz: Z) (pos: ptrofs) + | Freeframe (sz: Z) (pos: ptrofs) + | Freeframe2 (sz: Z) (pos: ptrofs) | Constant (v: val) . @@ -334,6 +336,32 @@ Definition op_eval (o: op) (l: list value) := | None => None | Some m => Some (Memstate m) end + | Freeframe sz pos, [Val spv; Memstate m] => + match Mem.loadv Mptr m (Val.offset_ptr spv pos) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (Memstate m') + end + | _ => None + end + end + | Freeframe2 sz pos, [Val spv; Memstate m] => + match Mem.loadv Mptr m (Val.offset_ptr spv pos) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (Val v) + end + | _ => None + end + end | Constant v, [] => Some (Val v) | _, _ => None end. @@ -417,6 +445,9 @@ Definition op_eq (o1 o2: op): ?? bool := | Store i1, Store i2 => store_op_eq i1 i2 | Control i1, Control i2 => control_op_eq i1 i2 | Allocframe sz1 pos1, Allocframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) + | Freeframe sz1 pos1, Freeframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) + | Freeframe2 sz1 pos1, Freeframe2 sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) + | Constant c1, Constant c2 => phys_eq c1 c2 | _, _ => RET false end. @@ -429,6 +460,9 @@ Proof. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit control_op_eq_correct. eassumption. eauto. congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - congruence. Qed. End IMPPARAM. @@ -519,45 +553,21 @@ Definition trans_basic (b: basic) : macro := | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (Name (#s) @ Name (#a) @ Name pmem @ Enil))] | Pallocframe sz pos => [(pmem, Op (Allocframe sz pos) (Name (#SP) @ Name pmem @ Enil)); (#FP, Name (#SP)); (#SP, Name (#RTMP)); (#RTMP, Op (Constant Vundef) Enil)] - | _ => [] + | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); + (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); + (#RTMP, Op (Constant Vundef) Enil)] + | Pget rd ra => [(#rd, Name (#ra))] + | Pset ra rd => [(#ra, Name (#rd))] + | Pnop => [] end. -(* - | Pfreeframe sz pos => - match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with - | None => Stuck - | Some v => - match rs SP with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => Stuck - | Some m' => Next (rs#SP <- v #RTMP <- Vundef) m' - end - | _ => Stuck - end - end - | Pget rd ra => - match ra with - | RA => Next (rs#rd <- (rs#ra)) m - | _ => Stuck - end - | Pset ra rd => - match ra with - | RA => Next (rs#ra <- (rs#rd)) m - | _ => Stuck - end - | Pnop => Next rs m - end. *) - Fixpoint trans_body (b: list basic) : list L.macro := match b with | nil => nil | b :: lb => (trans_basic b) :: (trans_body lb) end. -(* Definition trans_block (b: bblock) : L.bblock := +Definition trans_block (b: Asmblock.bblock) : L.bblock := trans_body (body b) ++ trans_exit (exit b). -. - *) End SECT. -- cgit From 54a8a3d2ffd4b49db453af12d364db37e6efdd0d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 21 Feb 2019 10:47:10 +0100 Subject: PostpassScheduling: outcome' = option state' --- mppa_k1c/PostpassScheduling.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 8700a472..1b56d3ab 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -29,7 +29,7 @@ Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) : bblock_equiv ge f bb bb'. Axiom state': Type. -Inductive outcome' := Next' : state' -> outcome' | Stuck' : outcome'. +Definition outcome' := option state'. Axiom bblock': Type. Extract Constant bblock' => "PostpassSchedulingOracle.bblock'". (* FIXME *) @@ -61,18 +61,18 @@ Axiom forward_simu: exec ge fn b rs1 m1 = Next rs2 m2 -> match_states (State rs1 m1) s1' -> exists s2', - exec' ge fn (trans_block b) s1' = Next' s2' + exec' ge fn (trans_block b) s1' = Some s2' /\ match_states (State rs2 m2) s2'. Axiom forward_simu_stuck: forall rs1 m1 s1' b ge fn, exec ge fn b rs1 m1 = Stuck -> match_states (State rs1 m1) s1' -> - exec' ge fn (trans_block b) s1' = Stuck'. + exec' ge fn (trans_block b) s1' = None. Axiom trans_block_reverse_stuck: forall ge fn b rs m s', - exec' ge fn (trans_block b) s' = Stuck' -> + exec' ge fn (trans_block b) s' = None -> match_states (State rs m) s' -> exec ge fn b rs m = Stuck. -- cgit From 61371b48ed52716e0b0cb8f2b067aaff7b9a610f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 21 Feb 2019 15:49:14 +0100 Subject: Starting forward simulation Asmblock -> Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 119 +++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 97 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index bb107574..9c6d67a2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -11,20 +11,6 @@ Require Import ImpDep. Open Scope impure. -(* FIXME - incompatible with IDP (not without additional code) so commenting it out *) -(* Module R<: ResourceNames. - -Inductive t_wrap := Reg (r: preg) | Mem. - -Definition t := t_wrap. - -Lemma eq_dec : forall (x y: t), { x = y } + { x<>y }. -Proof. - decide equality. decide equality; apply ireg_eq. -Qed. - -End R. *) - Module P<: ImpParam. Module R := Pos. @@ -35,7 +21,7 @@ Definition env := Genv.t fundef unit. Inductive genv_wrap := Genv (ge: env) (fn: function). Definition genv := genv_wrap. -Variable GE: genv. +Variable Ge: genv. Inductive value_wrap := | Val (v: val) @@ -48,6 +34,7 @@ Inductive control_op := | Oj_l (l: label) | Ocb (bt: btest) (l: label) | Ocbu (bt: btest) (l: label) + | OError . Inductive arith_op := @@ -103,7 +90,7 @@ Coercion Control: control_op >-> op_wrap. Definition op := op_wrap. Definition arith_eval (ao: arith_op) (l: list value) := - let (ge, fn) := GE in + let (ge, fn) := Ge in match ao, l with | OArithR n, [] => match n with @@ -231,7 +218,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := Definition exec_load_deps (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := - let (ge, fn) := GE in + let (ge, fn) := Ge in match (eval_offset ge ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with @@ -261,7 +248,7 @@ Definition load_eval (lo: load_op) (l: list value) := Definition exec_store_deps (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := - let (ge, fn) := GE in + let (ge, fn) := Ge in match (eval_offset ge ofs) with | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with @@ -305,7 +292,7 @@ Definition eval_branch_deps (f: function) (l: label) (vpc: val) (res: option boo end. Definition control_eval (o: control_op) (l: list value) := - let (ge, fn) := GE in + let (ge, fn) := Ge in match o, l with | Oj_l l, [Val vpc] => goto_label_deps fn l vpc | Ocb bt l, [Val v; Val vpc] => @@ -320,6 +307,7 @@ Definition control_eval (o: control_op) (l: list value) := | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong (Int64.repr 0))) | (None, _) => None end + | OError, _ => None | _, _ => None end. @@ -484,7 +472,7 @@ Import P. (** Compilation from Asmblock to L *) Section SECT. -Variable GE: genv. +Variable Ge: genv. Definition pmem : R.t := 1. @@ -500,6 +488,20 @@ Definition ireg_to_pos (ir: ireg) : R.t := end . +Local Open Scope positive_scope. + +Definition pos_to_ireg (p: R.t) : option gpreg := + match p with + | 1 => Some GPR0 | 2 => Some GPR1 | 3 => Some GPR2 | 4 => Some GPR3 | 5 => Some GPR4 | 6 => Some GPR5 | 7 => Some GPR6 | 8 => Some GPR7 | 9 => Some GPR8 | 10 => Some GPR9 + | 11 => Some GPR10 | 12 => Some GPR11 | 13 => Some GPR12 | 14 => Some GPR13 | 15 => Some GPR14 | 16 => Some GPR15 | 17 => Some GPR16 | 18 => Some GPR17 | 19 => Some GPR18 | 20 => Some GPR19 + | 21 => Some GPR20 | 22 => Some GPR21 | 23 => Some GPR22 | 24 => Some GPR23 | 25 => Some GPR24 | 26 => Some GPR25 | 27 => Some GPR26 | 28 => Some GPR27 | 29 => Some GPR28 | 30 => Some GPR29 + | 31 => Some GPR30 | 32 => Some GPR31 | 33 => Some GPR32 | 34 => Some GPR33 | 35 => Some GPR34 | 36 => Some GPR35 | 37 => Some GPR36 | 38 => Some GPR37 | 39 => Some GPR38 | 40 => Some GPR39 + | 41 => Some GPR40 | 42 => Some GPR41 | 43 => Some GPR42 | 44 => Some GPR43 | 45 => Some GPR44 | 46 => Some GPR45 | 47 => Some GPR46 | 48 => Some GPR47 | 49 => Some GPR48 | 50 => Some GPR49 + | 51 => Some GPR50 | 52 => Some GPR51 | 53 => Some GPR52 | 54 => Some GPR53 | 55 => Some GPR54 | 56 => Some GPR55 | 57 => Some GPR56 | 58 => Some GPR57 | 59 => Some GPR58 | 60 => Some GPR59 + | 61 => Some GPR60 | 62 => Some GPR61 | 63 => Some GPR62 | 64 => Some GPR63 + | _ => None + end. + Definition ppos (r: preg) : R.t := match r with | RA => 2 @@ -508,6 +510,16 @@ Definition ppos (r: preg) : R.t := end . +Definition inv_ppos (p: R.t) : option preg := + match p with + | 1 => None + | 2 => Some RA | 3 => Some PC + | n => match pos_to_ireg (n-3) with + | None => None + | Some gpr => Some (IR gpr) + end + end. + Notation "# r" := (ppos r) (at level 100, right associativity). Notation "a @ b" := (Econs a b) (at level 102, right associativity). @@ -522,7 +534,7 @@ Definition trans_control (ctl: control) : macro := | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Name pmem @ Enil))] - | _ => nil + | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. Definition trans_exit (ex: option control) : list L.macro := @@ -570,4 +582,67 @@ Fixpoint trans_body (b: list basic) : list L.macro := Definition trans_block (b: Asmblock.bblock) : L.bblock := trans_body (body b) ++ trans_exit (exit b). -End SECT. +Definition state := L.mem. +Definition exec := L.run. + +Definition match_states (s: Asmblock.state) (s': state) := + let (rs, m) := s in + s' pmem = Memstate m + /\ forall r, s' (#r) = Val (rs r). + +Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). + +Definition empty_state : state := (fun _ => Val Vundef). + +Definition trans_state (s: Asmblock.state) : state := + let (rs, m) := s in + fun x => if (Pos.eq_dec x pmem) then Memstate m + else match (inv_ppos x) with + | Some r => Val (rs r) + | None => Val Vundef + end. + +Theorem trans_state_match: forall S, match_states S (trans_state S). +Proof. + intros. destruct S as (rs & m). simpl. + split. reflexivity. + intro. destruct r; try reflexivity. + destruct g; reflexivity. +Qed. + +Lemma exec_match_app: + forall c c' s s' s'', + exec Ge c s = Some s' -> + exec Ge c' s' = Some s'' -> + exec Ge (c ++ c') s = Some s''. +Proof. +Admitted. + +Lemma forward_simu_body: + forall ge bdy rs m rs' m' fn s, + Ge = Genv ge fn -> + exec_body ge bdy rs m = Next rs' m' -> + match_states (State rs m) s -> + exists s', + exec Ge (trans_body bdy) s = Some s' + /\ match_states (State rs' m') s'. +Proof. +Admitted. + +Theorem forward_simu: + forall rs1 m1 rs2 m2 s1' b ge fn, + Ge = Genv ge fn -> + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + match_states (State rs1 m1) s1' -> + exists s2', + exec Ge (trans_block b) s1' = Some s2' + /\ match_states (State rs2 m2) s2'. +Proof. + intros until fn. intros GENV EXECB MS. unfold exec_bblock in EXECB. destruct (exec_body _ _ _) eqn:EXEB; try discriminate. + exploit forward_simu_body; eauto. intros (s' & EXETRANSB & MS'). + + eexists. split. + unfold trans_block. eapply exec_match_app. eassumption. +Admitted. + +End SECT. -- cgit From 721a9fa45aa53ed00b201c6f2b3a16713205a2cd Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 21 Feb 2019 15:50:40 +0100 Subject: machblockgen.v recursion terminale --- mppa_k1c/Machblockgen.v | 582 ++++-------------------------------------------- 1 file changed, 47 insertions(+), 535 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 1d5555df..a0786ac1 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -15,552 +15,64 @@ Require Import Mach. Require Import Linking. Require Import Machblock. +Inductive Machblock_inst: Type := +| MB_label (lbl: label) +| MB_basic (bi: basic_inst) +| MB_cfi (cfi: control_flow_inst). -Fixpoint to_bblock_header (c: Mach.code): list label * Mach.code := - match c with - | (Mlabel l)::c' => - let (h, c'') := to_bblock_header c' in - (l::h, c'') - | _ => (nil, c) - end. - -Definition to_basic_inst(i: Mach.instruction): option basic_inst := +Definition trans_inst (i:Mach.instruction) : Machblock_inst := match i with - | Mgetstack ofs ty dst => Some (MBgetstack ofs ty dst) - | Msetstack src ofs ty => Some (MBsetstack src ofs ty) - | Mgetparam ofs ty dst => Some (MBgetparam ofs ty dst) - | Mop op args res => Some (MBop op args res) - | Mload chunk addr args dst => Some (MBload chunk addr args dst) - | Mstore chunk addr args src => Some (MBstore chunk addr args src) - | _ => None - end. - -Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code := - match c with - | nil => (nil,nil) - | i::c' => - match to_basic_inst i with - | Some bi => - let (p,c'') := to_bblock_body c' in - (bi::p, c'') - | None => (nil, c) - end + | Mcall sig ros => MB_cfi (MBcall sig ros) + | Mtailcall sig ros => MB_cfi (MBtailcall sig ros) + | Mbuiltin ef args res => MB_cfi (MBbuiltin ef args res) + | Mgoto lbl => MB_cfi (MBgoto lbl) + | Mcond cond args lbl => MB_cfi (MBcond cond args lbl) + | Mjumptable arg tbl => MB_cfi (MBjumptable arg tbl) + | Mreturn => MB_cfi (MBreturn) + | Mgetstack ofs ty dst => MB_basic (MBgetstack ofs ty dst) + | 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) + | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) + | Mlabel l => MB_label l end. - -Definition to_cfi (i: Mach.instruction): option control_flow_inst := +Definition add_to_new_bblock (i:Machblock_inst) : bblock := match i with - | Mcall sig ros => Some (MBcall sig ros) - | Mtailcall sig ros => Some (MBtailcall sig ros) - | Mbuiltin ef args res => Some (MBbuiltin ef args res) - | Mgoto lbl => Some (MBgoto lbl) - | Mcond cond args lbl => Some (MBcond cond args lbl) - | Mjumptable arg tbl => Some (MBjumptable arg tbl) - | Mreturn => Some (MBreturn) - | _ => None + | MB_label l => {| header := l::nil; body := nil; exit := None |} + | MB_basic i => {| header := nil; body := i::nil; exit := None |} + | MB_cfi i => {| header := nil; body := nil; exit := Some i |} end. -Definition to_bblock_exit (c: Mach.code): option control_flow_inst * Mach.code := - match c with - | nil => (None,nil) - | i::c' => - match to_cfi i with - | Some bi as o => (o, c') - | None => (None, c) - 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)*) +Definition add_to_code (i:Machblock_inst) (bl:code) : code := + match bl with + | h::bl0 => match i with + | MB_label l => {| header := l::(header h); body := (body h); exit := (exit h) |}::bl0 + | MB_cfi i0 => add_to_new_bblock(i)::bl + | MB_basic i0 => match (header h) with + |_::_ => (add_to_new_bblock i)::bl + | nil => {| header := (header h); body := i0::(body h); exit := (exit h) |}::bl0 + end + end + | _ => (add_to_new_bblock i)::nil end. - -Inductive code_nature: Set := IsEmpty | IsLabel | IsBasicInst | IsCFI. - -Definition get_code_nature (c: Mach.code): code_nature := + +Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := match c with - | nil => IsEmpty - | (Mlabel _)::_ => IsLabel - | i::_ => match to_basic_inst i with - | Some _ => IsBasicInst - | None => IsCFI - end + | nil => bl + | i::c0 => + trans_code_rev c0 (add_to_code (trans_inst i) bl) end. -Lemma cn_eqdec (cn1 cn2: code_nature): { cn1=cn2 } + {cn1 <> cn2}. -Proof. - decide equality. -Qed. - -Lemma get_code_nature_nil c: c<>nil -> get_code_nature c <> IsEmpty. -Proof. - intros H. unfold get_code_nature. - destruct c; try (contradict H; auto; fail). - destruct i; discriminate. -Qed. - -Lemma get_code_nature_empty c: get_code_nature c = IsEmpty -> c = nil. -Proof. - intros H. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. - intro F. contradict F. -Qed. - -Lemma to_bblock_header_noLabel c: - get_code_nature c <> IsLabel -> - to_bblock_header c = (nil, c). -Proof. - intros H. destruct c as [|i c]; auto. - destruct i; simpl; auto. - contradict H; simpl; auto. -Qed. - -Lemma to_bblock_header_wfe c: - forall h c0, - to_bblock_header c = (h, c0) -> - (length c >= length c0)%nat. -Proof. - induction c as [ |i c]; simpl; intros h c' H. - - inversion H; subst; clear H; simpl; auto. - - destruct i; try (inversion H; subst; simpl; auto; fail). - remember (to_bblock_header c) as bhc; destruct bhc as [h0 c0]. - inversion H; subst. - lapply (IHc h0 c'); auto. -Qed. - -Lemma to_bblock_header_wf c b c0: - get_code_nature c = IsLabel -> - to_bblock_header c = (b, c0) -> - (length c > length c0)%nat. -Proof. - intros H1 H2; destruct c; [ contradict H1; simpl; discriminate | ]. - destruct i; try discriminate. - simpl in H2. - remember (to_bblock_header c) as bh; destruct bh as [h c'']. - inversion H2; subst. - exploit to_bblock_header_wfe; eauto. - simpl; omega. -Qed. - -Lemma to_bblock_body_noBasic c: - get_code_nature c <> IsBasicInst -> - to_bblock_body c = (nil, c). -Proof. - intros H. destruct c as [|i c]; simpl; auto. - destruct i; simpl; auto. - all: contradict H; simpl; auto. -Qed. - -Lemma to_bblock_body_wfe c b c0: - to_bblock_body c = (b, c0) -> - (length c >= length c0)%nat. -Proof. - generalize b c0; clear b c0. - induction c as [|i c]. - - intros b c0 H. simpl in H. inversion H; subst; auto. - - intros b c0 H. simpl in H. destruct (to_basic_inst i). - + remember (to_bblock_body c) as tbbc; destruct tbbc as [p c'']. - exploit (IHc p c''); auto. inversion H; subst; simpl; omega. - + inversion H; subst; auto. -Qed. - -(** Attempt to eliminate cons_to_bblock_body *) -(* -Lemma to_bblock_body_basic c: - get_code_nature c = IsBasicInst -> - exists i bi b c', - to_basic_inst i = Some bi - /\ c = i :: c' - /\ to_bblock_body c = (bi::b, snd (to_bblock_body c')). -Proof. - intros H. - destruct c as [|i c]; try (contradict H; simpl; discriminate). - destruct i eqn:I; try (contradict H; simpl; discriminate). - all: simpl; destruct (to_bblock_body c) as [p c''] eqn:TBBC; repeat (eapply ex_intro); (repeat split); - simpl; eauto; rewrite TBBC; simpl; eauto. -Qed. - -Lemma to_bblock_body_wf c b c0: - get_code_nature c = IsBasicInst -> - to_bblock_body c = (b, c0) -> - (length c > length c0)%nat. -Proof. - intros H1 H2; exploit to_bblock_body_basic; eauto. - intros X. destruct X as (i & bi & b' & c' & X1 & X2 & X3). - exploit to_bblock_body_wfe. eauto. subst. simpl. - rewrite X3 in H2. inversion H2; clear H2; subst. - simpl; omega. -Qed. -*) - -Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := - Cons_to_bbloc_body i bi c' b': - to_basic_inst i = Some bi - -> to_bblock_body c' = (b', c0) - -> cons_to_bblock_body c0 (i::c') (bi::b'). - -Lemma to_bblock_body_IsBasicInst c b c0: - get_code_nature c = IsBasicInst -> - to_bblock_body c = (b, c0) -> - cons_to_bblock_body c0 c b. -Proof. - intros H1 H2. destruct c; [ contradict H1; simpl; discriminate | ]. - remember (to_basic_inst i) as tbii. destruct tbii. - - simpl in H2. rewrite <- Heqtbii in H2. - remember (to_bblock_body c) as tbbc. destruct tbbc as [p1 c1]. - inversion H2. subst. eapply Cons_to_bbloc_body; eauto. - - destruct i; try discriminate. -Qed. - -Lemma to_bblock_body_wf c b c0: - get_code_nature c = IsBasicInst -> - to_bblock_body c = (b, c0) -> - (length c > length c0)%nat. -Proof. - intros H1 H2; exploit to_bblock_body_IsBasicInst; eauto. - intros X. destruct X. - exploit to_bblock_body_wfe; eauto. subst. simpl. - simpl; omega. -Qed. - -Lemma to_bblock_exit_noCFI c: - get_code_nature c <> IsCFI -> - to_bblock_exit c = (None, c). -Proof. - intros H. destruct c as [|i c]; simpl; auto. - destruct i; simpl; auto. - all: contradict H; simpl; auto. -Qed. - -Lemma to_bblock_exit_wf c b c0: - get_code_nature c = IsCFI -> - to_bblock_exit c = (b, c0) -> - (length c > length c0)%nat. -Proof. - intros H1 H2. destruct c as [|i c]; try discriminate. - destruct i; try discriminate; - unfold to_bblock_header in H2; inversion H2; auto. -Qed. - -Lemma to_bblock_exit_wfe c b c0: - to_bblock_exit c = (b, c0) -> - (length c >= length c0)%nat. -Proof. - intros H. destruct c as [|i c]. - - simpl in H. inversion H; subst; clear H; auto. - - destruct i; try ( simpl in H; inversion H; subst; clear H; auto ). - all: simpl; auto. -Qed. - -Definition to_bblock(c: Mach.code): bblock * Mach.code := - let (h,c0) := to_bblock_header c in - let (bdy, c1) := to_bblock_body c0 in - let (ext, c2) := to_bblock_exit c1 in - ({| header := h; body := bdy; exit := ext |}, c2) - . - -Lemma to_bblock_acc_label c l b c': - to_bblock c = (b, c') -> - to_bblock (Mlabel l :: c) = ({| header := l::(header b); body := (body b); exit := (exit b) |}, c'). -Proof. - unfold to_bblock; simpl. - remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. - remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. - remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. - intros H; inversion H; subst; clear H; simpl; auto. -Qed. - -Lemma to_bblock_basic_then_label i c bi: - get_code_nature (i::c) = IsBasicInst -> - get_code_nature c = IsLabel -> - to_basic_inst i = Some bi -> - fst (to_bblock (i::c)) = {| header := nil; body := bi::nil; exit := None |}. -Proof. - intros H1 H2 H3. - destruct c as [|i' c]; try (contradict H1; simpl; discriminate). - destruct i'; try (contradict H1; simpl; discriminate). - destruct i; simpl in *; inversion H3; subst; auto. -Qed. - -Lemma to_bblock_CFI i c cfi: - get_code_nature (i::c) = IsCFI -> - to_cfi i = Some cfi -> - fst (to_bblock (i::c)) = {| header := nil; body := nil; exit := Some cfi |}. -Proof. - intros H1 H2. - destruct i; try discriminate. - all: subst; rewrite <- H2; simpl; auto. -Qed. - -Lemma to_bblock_noLabel c: - get_code_nature c <> IsLabel -> - fst (to_bblock c) = {| - header := nil; - body := body (fst (to_bblock c)); - exit := exit (fst (to_bblock c)) - |}. -Proof. - intros H. - destruct c as [|i c]; simpl; auto. - apply bblock_eq; simpl; - destruct i; ( - try ( - remember (to_bblock _) as bb; - unfold to_bblock in *; - remember (to_bblock_header _) as tbh; - destruct tbh; - destruct (to_bblock_body _); - destruct (to_bblock_exit _); - subst; simpl; inversion Heqtbh; auto; fail - ) - || contradict H; simpl; auto ). -Qed. - -Lemma to_bblock_body_nil c c': - to_bblock_body c = (nil, c') -> - c = c'. -Proof. - intros H. - destruct c as [|i c]; [ simpl in *; inversion H; auto |]. - destruct i; try ( simpl in *; remember (to_bblock_body c) as tbc; destruct tbc as [p c'']; inversion H ). - all: auto. -Qed. - -Lemma to_bblock_exit_nil c c': - to_bblock_exit c = (None, c') -> - c = c'. -Proof. - intros H. - destruct c as [|i c]; [ simpl in *; inversion H; auto |]. - destruct i; try ( simpl in *; remember (to_bblock_exit c) as tbe; destruct tbe as [p c'']; inversion H ). - all: auto. -Qed. - -Lemma to_bblock_label b l c c': - to_bblock (Mlabel l :: c) = (b, c') -> - (header b) = l::(tail (header b)) /\ to_bblock c = ({| header:=tail (header b); body := body b; exit := exit b |}, c'). -Proof. - unfold to_bblock; simpl. - remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. - remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. - remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. - intros H; inversion H; subst; clear H; simpl; auto. -Qed. - -Lemma to_bblock_basic c i bi: - get_code_nature (i::c) = IsBasicInst -> - to_basic_inst i = Some bi -> - get_code_nature c <> IsLabel -> - fst (to_bblock (i::c)) = {| - header := nil; - body := bi :: body (fst (to_bblock c)); - exit := exit (fst (to_bblock c)) - |}. -Proof. - intros. - destruct c; try (destruct i; inversion H0; subst; simpl; auto; fail). - apply bblock_eq; simpl. -(* header *) - + destruct i; simpl; auto; ( - exploit to_bblock_noLabel; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]). -(* body *) -(* FIXME - the proof takes some time to prove.. N² complexity :( *) - + unfold to_bblock. - remember (to_bblock_header _) as tbh; destruct tbh. - remember (to_bblock_body _) as tbb; destruct tbb. - remember (to_bblock_exit _) as tbe; destruct tbe. - simpl. - destruct i; destruct i0. - all: try (simpl in H1; contradiction). - all: try discriminate. - all: try ( - simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; - simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; - inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; - inversion H0; clear H0; subst; destruct (to_bblock_body c); - inversion Heqtbbc; clear Heqtbbc; subst; - destruct (to_bblock_exit c1); simpl; auto; fail). -(* exit *) - + unfold to_bblock. - remember (to_bblock_header _) as tbh; destruct tbh. - remember (to_bblock_body _) as tbb; destruct tbb. - remember (to_bblock_exit _) as tbe; destruct tbe. - simpl. - destruct i; destruct i0. - all: try (simpl in H1; contradiction). - all: try discriminate. - all: try ( - simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; - simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; - inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; - inversion H0; clear H0; subst; destruct (to_bblock_body c) eqn:TBBC; - inversion Heqtbbc; clear Heqtbbc; subst; - destruct (to_bblock_exit c1) eqn:TBBE; simpl; - inversion Heqtbe; clear Heqtbe; subst; auto; fail). -Qed. - -Lemma to_bblock_size_single_label c i: - get_code_nature (i::c) = IsLabel -> - size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). -Proof. - intros H. - destruct i; try discriminate. - remember (to_bblock c) as bl. destruct bl as [b c']. - erewrite to_bblock_acc_label; eauto. - unfold size; simpl. - auto. -Qed. - -Lemma to_bblock_size_label_neqz c: - get_code_nature c = IsLabel -> - size (fst (to_bblock c)) <> 0%nat. -Proof. - destruct c as [ |i c]; try discriminate. - intros; rewrite to_bblock_size_single_label; auto. -Qed. - -Lemma to_bblock_size_basic_neqz c: - get_code_nature c = IsBasicInst -> - size (fst (to_bblock c)) <> 0%nat. -Proof. - intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). - destruct i; try (contradict H; simpl; discriminate); - ( - destruct (get_code_nature c) eqn:gcnc; - (* Case gcnc is not IsLabel *) - try (erewrite to_bblock_basic; eauto; [ - unfold size; simpl; auto - | simpl; auto - | rewrite gcnc; discriminate - ]); - erewrite to_bblock_basic_then_label; eauto; [ - unfold size; simpl; auto - | simpl; auto - ] - ). -Qed. - -Lemma to_bblock_size_cfi_neqz c: - get_code_nature c = IsCFI -> - size (fst (to_bblock c)) <> 0%nat. -Proof. - intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). - destruct i; discriminate. -Qed. - -Lemma to_bblock_size_single_basic c i: - get_code_nature (i::c) = IsBasicInst -> - get_code_nature c <> IsLabel -> - size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). -Proof. - intros. - destruct i; try (contradict H; simpl; discriminate); try ( - (exploit to_bblock_basic; eauto); - [remember (to_basic_inst _) as tbi; destruct tbi; eauto |]; - intro; rewrite H1; unfold size; simpl; - assert ((length (header (fst (to_bblock c)))) = 0%nat); - exploit to_bblock_noLabel; eauto; intro; rewrite H2; simpl; auto; - rewrite H2; auto - ). -Qed. - -Lemma to_bblock_wf c b c0: - c <> nil -> - to_bblock c = (b, c0) -> - (length c > length c0)%nat. -Proof. - intro H; lapply (get_code_nature_nil c); eauto. - intro H'; remember (get_code_nature c) as gcn. - unfold to_bblock. - remember (to_bblock_header c) as p1; eauto. - destruct p1 as [h c1]. - intro H0. - destruct gcn. - - contradict H'; auto. - - exploit to_bblock_header_wf; eauto. - remember (to_bblock_body c1) as p2; eauto. - destruct p2 as [h2 c2]. - exploit to_bblock_body_wfe; eauto. - remember (to_bblock_exit c2) as p3; eauto. - destruct p3 as [h3 c3]. - exploit to_bblock_exit_wfe; eauto. - inversion H0. omega. - - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. - intro. rewrite H1 in Heqp1. inversion Heqp1. clear Heqp1. subst. - remember (to_bblock_body c) as p2; eauto. - destruct p2 as [h2 c2]. - exploit to_bblock_body_wf; eauto. - remember (to_bblock_exit c2) as p3; eauto. - destruct p3 as [h3 c3]. - exploit to_bblock_exit_wfe; eauto. - inversion H0. omega. - - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. - intro. rewrite H1 in Heqp1. inversion Heqp1; clear Heqp1; subst. - remember (to_bblock_body c) as p2; eauto. - destruct p2 as [h2 c2]. - exploit (to_bblock_body_noBasic c); eauto. rewrite <- Heqgcn. discriminate. - intros H2; rewrite H2 in Heqp2; inversion Heqp2; clear Heqp2; subst. - remember (to_bblock_exit c) as p3; eauto. - destruct p3 as [h3 c3]. - exploit (to_bblock_exit_wf c h3 c3); eauto. - inversion H0. omega. -Qed. - -Lemma to_bblock_nonil i c0: - size (fst (to_bblock (i :: c0))) <> 0%nat. -Proof. - intros H. remember (i::c0) as c. remember (get_code_nature c) as gcnc. destruct gcnc. - - contradict Heqgcnc. subst. simpl. destruct i; discriminate. - - eapply to_bblock_size_label_neqz; eauto. - - eapply to_bblock_size_basic_neqz; eauto. - - eapply to_bblock_size_cfi_neqz; eauto. -Qed. - -Function trans_code (c: Mach.code) { measure length c }: code := - match c with - | nil => nil - | _ => - let (b, c0) := to_bblock c in - b::(trans_code c0) - end. -Proof. - intros; eapply to_bblock_wf; eauto. discriminate. -Qed. - -Lemma trans_code_nonil c: - c <> nil -> trans_code c <> nil. -Proof. - intros H. - induction c, (trans_code c) using trans_code_ind; simpl; auto. discriminate. -Qed. - -Lemma trans_code_step c b lb0 hb c1 bb c2 eb c3: - trans_code c = b :: lb0 -> - to_bblock_header c = (hb, c1) -> - to_bblock_body c1 = (bb, c2) -> - to_bblock_exit c2 = (eb, c3) -> - hb = header b /\ bb = body b /\ eb = exit b /\ trans_code c3 = lb0. -Proof. - intros. - induction c, (trans_code c) using trans_code_ind. discriminate. clear IHc0. - subst. destruct _x as [|i c]; try (contradict y; auto; fail). - inversion H; subst. clear H. unfold to_bblock in e0. - remember (to_bblock_header (i::c)) as hd. destruct hd as [hb' c1']. - remember (to_bblock_body c1') as bd. destruct bd as [bb' c2']. - remember (to_bblock_exit c2') as be. destruct be as [eb' c3']. - inversion e0. simpl. - inversion H0. subst. - rewrite <- Heqbd in H1. inversion H1. subst. - rewrite <- Heqbe in H2. inversion H2. subst. - auto. -Qed. - -Lemma trans_code_cfi i c cfi: - to_cfi i = Some cfi -> - trans_code (i :: c) = {| header := nil ; body := nil ; exit := Some cfi |} :: trans_code c. -Proof. - intros. rewrite trans_code_equation. remember (to_bblock _) as tb; destruct tb as [b c0]. - destruct i; try (contradict H; discriminate). - all: unfold to_bblock in Heqtb; remember (to_bblock_header _) as tbh; destruct tbh as [h c0']; - remember (to_bblock_body c0') as tbb; destruct tbb as [bdy c1']; - remember (to_bblock_exit c1') as tbe; destruct tbe as [ext c2]; simpl in *; - inversion Heqtbh; subst; inversion Heqtbb; subst; inversion Heqtbe; subst; - inversion Heqtb; subst; rewrite H; auto. -Qed. +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 := -- cgit From 4ae65ffdf5df6b45178520db7f042f67887728df Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 21 Feb 2019 17:32:56 +0100 Subject: Separated forward_simulation into body and exit (Asmblockdeps) --- mppa_k1c/Asmblockdeps.v | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9c6d67a2..815eb065 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -35,6 +35,7 @@ Inductive control_op := | Ocb (bt: btest) (l: label) | Ocbu (bt: btest) (l: label) | OError + | OIncremPC (sz: Z) . Inductive arith_op := @@ -307,6 +308,7 @@ Definition control_eval (o: control_op) (l: list value) := | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong (Int64.repr 0))) | (None, _) => None end + | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) | OError, _ => None | _, _ => None end. @@ -413,6 +415,8 @@ Definition control_op_eq (c1 c2: control_op): ?? bool := | Oj_l l1, Oj_l l2 => phys_eq l1 l2 | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) + | OIncremPC sz1, OIncremPC sz2 => phys_eq sz1 sz2 + | OError, OError => RET true | _, _ => RET false end. @@ -423,6 +427,7 @@ Proof. - congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - congruence. Qed. @@ -579,8 +584,10 @@ Fixpoint trans_body (b: list basic) : list L.macro := | b :: lb => (trans_basic b) :: (trans_body lb) end. +Definition trans_pcincr (sz: Z) := [(#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil))] :: nil. + Definition trans_block (b: Asmblock.bblock) : L.bblock := - trans_body (body b) ++ trans_exit (exit b). + trans_body (body b) ++ trans_pcincr (size b) ++ trans_exit (exit b). Definition state := L.mem. Definition exec := L.run. @@ -592,8 +599,6 @@ Definition match_states (s: Asmblock.state) (s': state) := Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). -Definition empty_state : state := (fun _ => Val Vundef). - Definition trans_state (s: Asmblock.state) : state := let (rs, m) := s in fun x => if (Pos.eq_dec x pmem) then Memstate m @@ -629,6 +634,17 @@ Lemma forward_simu_body: Proof. Admitted. +Lemma forward_simu_control: + forall ge fn ex b rs m rs2 m2 s, + Ge = Genv ge fn -> + exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> + match_states (State rs m) s -> + exists s', + exec Ge (trans_pcincr (size b) ++ trans_exit ex) s = Some s' + /\ match_states (State rs2 m2) s'. +Proof. +Admitted. + Theorem forward_simu: forall rs1 m1 rs2 m2 s1' b ge fn, Ge = Genv ge fn -> @@ -640,9 +656,11 @@ Theorem forward_simu: Proof. intros until fn. intros GENV EXECB MS. unfold exec_bblock in EXECB. destruct (exec_body _ _ _) eqn:EXEB; try discriminate. exploit forward_simu_body; eauto. intros (s' & EXETRANSB & MS'). + exploit forward_simu_control; eauto. intros (s'' & EXETRANSEX & MS''). eexists. split. - unfold trans_block. eapply exec_match_app. eassumption. -Admitted. + unfold trans_block. eapply exec_match_app. eassumption. eassumption. + eassumption. +Qed. End SECT. -- cgit From a86b505f9c392a558315df2d7acd08e914795f38 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 22 Feb 2019 13:05:51 +0100 Subject: squelette de preuve pour Machblockgenproof.v --- mppa_k1c/Machblockgen.v | 118 +++++++++++++++++++++++++++++++--- mppa_k1c/Machblockgenproof.v | 80 +++++++++++++++++++---- mppa_k1c/lib/ForwardSimulationBlock.v | 51 +++++++++++++++ 3 files changed, 228 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index a0786ac1..18abb927 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -38,11 +38,23 @@ Definition trans_inst (i:Mach.instruction) : Machblock_inst := | Mlabel l => MB_label l end. +Definition empty_bblock:={| header := nil; body := nil; exit := None |}. +Extraction Inline empty_bblock. + +Definition add_label l bb:={| header := l::(header bb); body := (body bb); exit := (exit bb) |}. +Extraction Inline add_label. + +Definition add_basic bi bb :={| header := nil; body := bi::(body bb); exit := (exit bb) |}. +Extraction Inline add_basic. + +Definition cfi_bblock cfi:={| header := nil; body := nil; exit := Some cfi |}. +Extraction Inline cfi_bblock. + Definition add_to_new_bblock (i:Machblock_inst) : bblock := match i with - | MB_label l => {| header := l::nil; body := nil; exit := None |} - | MB_basic i => {| header := nil; body := i::nil; exit := None |} - | MB_cfi i => {| header := nil; body := nil; exit := Some i |} + | MB_label l => add_label l empty_bblock + | MB_basic i => add_basic i empty_bblock + | MB_cfi i => cfi_bblock i end. (* ajout d'une instruction en début d'une liste de blocks *) @@ -53,15 +65,15 @@ Definition add_to_new_bblock (i:Machblock_inst) : bblock := (* label -> /1\ (dans header)*) Definition add_to_code (i:Machblock_inst) (bl:code) : code := match bl with - | h::bl0 => match i with - | MB_label l => {| header := l::(header h); body := (body h); exit := (exit h) |}::bl0 - | MB_cfi i0 => add_to_new_bblock(i)::bl - | MB_basic i0 => match (header h) with - |_::_ => (add_to_new_bblock i)::bl - | nil => {| header := (header h); body := i0::(body h); exit := (exit h) |}::bl0 + | bh::bl0 => match i with + | MB_label l => add_label l bh::bl0 + | MB_cfi i0 => cfi_bblock i0::bl + | MB_basic i0 => match header bh with + |_::_ => add_basic i0 empty_bblock::bl + | nil => add_basic i0 bh::bl0 end end - | _ => (add_to_new_bblock i)::nil + | _ => add_to_new_bblock i::nil end. Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := @@ -74,6 +86,7 @@ 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; @@ -88,3 +101,88 @@ Definition transf_fundef (f: Mach.fundef) : fundef := Definition transf_program (src: Mach.program) : program := transform_program transf_fundef src. + + +(** Abstraction de 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. + +Inductive is_trans_code: Mach.code -> code -> Prop := + | Tr_nil: is_trans_code nil nil + | Tr_end_block i c bl: + is_trans_code c bl -> + is_end_block (trans_inst i) bl -> + is_trans_code (i::c) (add_to_new_bblock (trans_inst i)::bl) + | Tr_add_label i l bh c bl: + is_trans_code c (bh::bl) -> + i = Mlabel l -> + is_trans_code (i::c) (add_label l bh::bl) + | Tr_add_basic i bi bh c bl: + is_trans_code c (bh::bl) -> + trans_inst i = MB_basic bi -> + header bh = nil -> + is_trans_code (i::c) (add_basic bi bh::bl). + +Local Hint Resolve Tr_nil Tr_end_block. + +Lemma add_to_code_is_trans_code i c bl: + is_trans_code c bl -> + is_trans_code (i::c) (add_to_code (trans_inst i) bl). +Proof. + destruct bl as [|bh0 bl]; simpl. + - intro H; inversion H; subst; eauto. + - remember (trans_inst i) as ti. + destruct ti as [l|bi|cfi]. + + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. + + +Admitted. (* A FINIR *) + +Local Hint Resolve add_to_code_is_trans_code. + +Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, + is_trans_code c2 mbi -> + is_trans_code (rev_append c1 c2) (trans_code_rev c1 mbi). +Proof. + induction c1 as [| i c1]; simpl; auto. +Qed. + +Lemma trans_code_is_trans_code c: is_trans_code c (trans_code c). +Proof. + unfold trans_code. + rewrite <- rev_alt. + rewrite <- (rev_involutive c) at 1. + rewrite rev_alt at 1. + apply trans_code_is_trans_code_rev; auto. +Qed. + +Lemma add_to_code_is_trans_code_inv i c bl: + is_trans_code (i::c) bl -> exists bl0, is_trans_code c bl0 /\ bl = add_to_code (trans_inst i) bl0. +Proof. + intro H; inversion H as [|H0 H1 bl0| | H0 bi bh H1 bl0]; clear H; subst; (repeat econstructor); eauto. + + (* case Tr_end_block *) inversion H3; subst; simpl; auto. + * destruct (header bh); congruence. + * destruct bl0; simpl; congruence. + + (* case Tr_add_basic *) +Admitted. (* A FINIR *) + +Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, + is_trans_code (rev_append c1 c2) mbi -> + exists mbi0, is_trans_code c2 mbi0 /\ mbi=trans_code_rev c1 mbi0. +Proof. + induction c1 as [| i c1]; simpl; eauto. + intros; exploit IHc1; eauto. + intros (mbi0 & H1 & H2); subst. + exploit add_to_code_is_trans_code_inv; eauto. +Admitted. (* A FINIR *) + +Local Hint Resolve trans_code_is_trans_code. + +Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). +Proof. + constructor; intros; subst; auto. +Admitted. (* A FINIR *) diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 62c1e0ed..d7a5ed7d 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -39,7 +39,7 @@ Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) end. -Definition trans_state (ms: Mach.state) : state := +Definition trans_state (ms: Mach.state): state := match ms with | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m @@ -170,6 +170,8 @@ Definition concat (h: list label) (c: code): code := | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' end. +(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? + Lemma to_bblock_start_label i c l b c0: (b, c0) = to_bblock (i :: c) -> In l (header b) @@ -264,13 +266,23 @@ Proof. - destruct i; try ( simpl in H; inversion H; subst; clear H; auto; fail). Qed. +*) + +Axiom TODO: False. (* A ELIMINER *) Lemma find_label_transcode_preserved: forall l c c', Mach.find_label l c = Some c' -> exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). Proof. - intros l c; induction c, (trans_code c) using trans_code_ind. + intros l c. remember (trans_code _) as bl. + rewrite <- is_trans_code_inv in * |-. + induction Heqbl; + elim TODO. (* A FAIRE *) +Qed. + +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? + induction c, (trans_code c) using trans_code_ind. - intros c' H; inversion H. - intros c' H. subst _x. destruct c as [| i c]; try tauto. unfold to_bblock in * |-. @@ -290,7 +302,7 @@ Proof. erewrite (to_bblock_body_find_label c1 l c2); eauto. erewrite (to_bblock_exit_find_label c2 l c0); eauto. Qed. - +*) Lemma find_label_preserved: forall l f c, @@ -311,7 +323,13 @@ Qed. Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated parent_sp_preserved. -Definition dist_end_block_code (c: Mach.code) := (size (fst (to_bblock c))-1)%nat. + + +Definition dist_end_block_code (c: Mach.code) := + match trans_code c with + | nil => 0 + | bh::_ => (size bh-1)%nat + end. Definition dist_end_block (s: Mach.state): nat := @@ -323,6 +341,8 @@ Definition dist_end_block (s: Mach.state): nat := Local Hint Resolve exec_nil_body exec_cons_body. Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. +(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? + Ltac ExploitDistEndBlockCode := match goal with | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => @@ -377,11 +397,22 @@ Proof. - contradict H. destruct i; try discriminate. all: unfold dist_end_block_code; erewrite to_bblock_CFI; eauto; simpl; eauto. Qed. +*) + +Lemma dist_end_block_code_simu_mid_block i c: + dist_end_block_code (i::c) <> 0 -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). +Proof. + unfold dist_end_block_code. + remember (trans_code (i::c)) as bl. + rewrite <- is_trans_code_inv in * |-. + inversion Heqbl as [| | |]; subst. +Admitted. (* A FAIRE *) Local Hint Resolve dist_end_block_code_simu_mid_block. Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): - to_basic_inst i = Some bi -> + trans_inst i = MB_basic bi -> Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. Proof. @@ -400,6 +431,7 @@ Proof. Qed. +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Lemma star_step_simu_body_step s f sp c: forall (p:bblock_body) c' rs m t s', to_bblock_body c = (p, c') -> @@ -426,6 +458,7 @@ Proof. inversion_clear H; simpl. intros X; inversion_clear X. intuition 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. @@ -433,6 +466,16 @@ Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved f Lemma match_states_concat_trans_code st f sp c rs m h: match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). Proof. + intros; remember (trans_code _) as bl. + rewrite <- is_trans_code_inv in * |-. + constructor 1; simpl. + + intros (t0 & s1' & H0) t s'. + inversion Heqbl as [| | |]; subst; simpl; (* inversion vs induction ?? *) + elim TODO. (* A FAIRE *) + + intros H r; constructor 1; intro X; inversion X. +Qed. + +(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? constructor 1; simpl. + intros (t0 & s1' & H0) t s'. rewrite! trans_code_equation. @@ -486,7 +529,6 @@ Proof. Qed. - Lemma step_simu_exit_step c e c' stk f sp rs m t s' b: to_bblock_exit c = (e, c') -> starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s' -> @@ -516,6 +558,7 @@ Proof. inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. exploit IHc; eauto. Qed. +*) Lemma simu_end_block: forall s1 t s1', @@ -524,14 +567,23 @@ Lemma simu_end_block: Proof. destruct s1; simpl. + (* State *) - (* c cannot be nil *) - destruct c as [|i c]; simpl; try ( (* nil => absurd *) + unfold dist_end_block_code. + remember (trans_code _) as bl. + rewrite <- is_trans_code_inv in * |-. + intros t s1' H. + inversion Heqbl as [| | |]; subst; simpl in * |- *; (* inversion vs induction ?? *) + elim TODO. (* A FAIRE *) + + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? + + destruct c as [|i c]; simpl; try ( (* nil => absurd *) unfold dist_end_block_code; simpl; intros t s1' H; inversion_clear H; inversion_clear H0; fail ). intros t s1' H. + remember (_::_) as c0. remember (trans_code c0) as tc0. (* tc0 cannot be nil *) @@ -576,6 +628,7 @@ Proof. intros (s2' & H3 & H4). eapply ex_intro; intuition eauto. eapply exec_bblock; eauto. +*) + (* Callstate *) intros t s1' H; inversion_clear H. eapply ex_intro; constructor 1; eauto. @@ -604,8 +657,10 @@ Theorem transf_program_correct: Proof. apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) - - intros s1 t s1' H1. + - intros s1 t s1' H1. elim TODO. (* A FAIRE *) + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? destruct H1; simpl; omega || (intuition auto). + *) (* public_preserved *) - apply senv_preserved. (* match_initial_states *) @@ -618,10 +673,13 @@ Proof. (* match_final_states *) - intros. simpl. destruct H. split with (r := r); auto. (* final_states_end_block *) - - intros. simpl in H0. inversion H0. - inversion H; simpl; auto. + - intros. simpl in H0. elim TODO. + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? + inversion H0. + inversion H; simpl; auto. (* the remaining instructions cannot lead to a Returnstate *) all: subst; discriminate. + *) (* simu_end_block *) - apply simu_end_block. Qed. diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v index dc8beb29..39dd2234 100644 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -271,6 +271,7 @@ However, the Machblock state after a goto remains "equivalent" to the trans_stat *) + Section ForwardSimuBlock_TRANS. Variable L1 L2: semantics. @@ -320,3 +321,53 @@ Proof. Qed. End ForwardSimuBlock_TRANS. + + +(* another version with a relation [trans_state_R] instead of a function [trans_state] *) +Section ForwardSimuBlock_TRANS_R. + +Variable L1 L2: semantics. + +Variable trans_state_R: state L1 -> state L2 -> Prop. + +Definition match_states_R s1 s2: Prop := + exists s2', trans_state_R s1 s2' /\ equiv_on_next_step _ (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 s2'. + +Lemma match_states_trans_state_R s1 s2: trans_state_R s1 s2 -> match_states_R s1 s2. +Proof. + unfold match_states, equiv_on_next_step. firstorder. +Qed. + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states_R s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 s2 r, final_state L1 s1 r -> trans_state_R s1 s2 -> final_state L2 s2 r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> trans_state_R s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states_R s1' s2'. + +Lemma forward_simulation_block_trans_R: forward_simulation L1 L2. +Proof. + eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states_R); try tauto. + + (* final_states *) intros s1 s2 r H1 (s2' & H2 & H3 & H4). rewrite H4; eauto. + + (* simu_end_block *) + intros s1 t s1' s2 H1 (s2' & H2 & H2a & H2b). exploit simu_end_block; eauto. + intros (x & Hx & (y & H3 & H4 & H5)). repeat (econstructor; eauto). + rewrite H2a; eauto. + inversion_clear H1. eauto. +Qed. + +End ForwardSimuBlock_TRANS_R. + -- cgit From bda4a3c82bfc735e7d1dd74ecc4a43545558178f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Feb 2019 14:11:06 +0100 Subject: Complete proof of forward_simu_control in Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 110 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 109 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 815eb065..83064762 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,5 +1,6 @@ Require Import AST. Require Import Asmblock. +Require Import Asmblockgenproof0. Require Import Values. Require Import Globalenvs. Require Import Memory. @@ -7,6 +8,7 @@ Require Import Errors. Require Import Integers. Require Import Floats. Require Import ZArith. +Require Import Coqlib. Require Import ImpDep. Open Scope impure. @@ -607,6 +609,30 @@ Definition trans_state (s: Asmblock.state) : state := | None => Val Vundef end. +Lemma pos_gpreg_not_3: forall g: gpreg, 3 <> # g. +Proof. + destruct g; try discriminate. +Qed. + +Lemma pos_gpreg_not_2: forall g: gpreg, 2 <> # g. +Proof. + destruct g; try 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) + || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not_3); try (apply pos_gpreg_not_2))) + || (rewrite assign_eq) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Arguments Pos.add: simpl never. + Theorem trans_state_match: forall S, match_states S (trans_state S). Proof. intros. destruct S as (rs & m). simpl. @@ -643,7 +669,89 @@ Lemma forward_simu_control: exec Ge (trans_pcincr (size b) ++ trans_exit ex) s = Some s' /\ match_states (State rs2 m2) s'. Proof. -Admitted. + intros. destruct ex. + - simpl in *. inv H1. destruct c; destruct i; try discriminate. + all: try (inv H0; eexists; split; try split; [ simpl control_eval; pose (H3 PC); simpl in e; rewrite e; reflexivity | Simpl | intros rr; destruct rr; Simpl]). + (* Pj_l *) + + unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. + eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. + rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + (* Pcb *) + + destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. + inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. + inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + (* Pcbu *) + + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold eval_branch in H0. destruct (Val.cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. + inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold eval_branch in H0. destruct (Val.cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. + inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. + rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + - simpl in *. inv H1. inv H0. eexists. split. + pose (H3 PC). simpl in e. rewrite e. simpl. reflexivity. + split. Simpl. + intros. unfold nextblock. destruct r; Simpl. +Qed. Theorem forward_simu: forall rs1 m1 rs2 m2 s1' b ge fn, -- cgit From 48de6f86fd3d0f1e326a1823d3b418501f80c5ae Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Feb 2019 16:32:22 +0100 Subject: forward_simu_basic proof until Pallocframe in Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 103 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 94 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 83064762..6bfbc67b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -80,6 +80,7 @@ Inductive op_wrap := | Store (so: store_op) | Control (co: control_op) | Allocframe (sz: Z) (pos: ptrofs) + | Allocframe2 (sz: Z) (pos: ptrofs) | Freeframe (sz: Z) (pos: ptrofs) | Freeframe2 (sz: Z) (pos: ptrofs) | Constant (v: val) @@ -328,6 +329,13 @@ Definition op_eval (o: op) (l: list value) := | None => None | Some m => Some (Memstate m) end + | Allocframe2 sz pos, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with + | None => None + | Some m => Some (Val sp) + end | Freeframe sz pos, [Val spv; Memstate m] => match Mem.loadv Mptr m (Val.offset_ptr spv pos) with | None => None @@ -570,8 +578,8 @@ Definition trans_basic (b: basic) : macro := | PArith ai => trans_arith ai | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (Name (#a) @ Name pmem @ Enil))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (Name (#s) @ Name (#a) @ Name pmem @ Enil))] - | Pallocframe sz pos => [(pmem, Op (Allocframe sz pos) (Name (#SP) @ Name pmem @ Enil)); - (#FP, Name (#SP)); (#SP, Name (#RTMP)); (#RTMP, Op (Constant Vundef) Enil)] + | Pallocframe sz pos => [(#FP, Name (#SP)); (#SP, Op (Allocframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); + (pmem, Op (Allocframe sz pos) (Old (Name (#SP)) @ Name pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil)] @@ -609,23 +617,36 @@ Definition trans_state (s: Asmblock.state) : state := | None => Val Vundef end. -Lemma pos_gpreg_not_3: forall g: gpreg, 3 <> # g. +Lemma pos_gpreg_not: forall g: gpreg, pmem <> (#g) /\ 2 <> (#g) /\ 3 <> (#g). Proof. - destruct g; try discriminate. + intros. split; try split. all: destruct g; try discriminate. Qed. -Lemma pos_gpreg_not_2: forall g: gpreg, 2 <> # g. +Lemma not_3_plus_n: + forall n, 3 + n <> pmem /\ 3 + n <> (# RA) /\ 3 + n <> (# PC). Proof. - destruct g; try discriminate. + intros. split; try split. + all: destruct n; simpl; try (destruct n; discriminate); try discriminate. Qed. +Lemma not_eq_ireg_to_pos: + forall n r r', r' <> r -> n + ireg_to_pos r <> n + ireg_to_pos r'. +Proof. +Admitted. + +Lemma not_eq_ireg_to_pos_ppos: + forall n r r', r' <> r -> n + ireg_to_pos r <> # r'. +Proof. +Admitted. + + 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) - || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not_3); try (apply pos_gpreg_not_2))) + || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not); try (apply not_3_plus_n))) || (rewrite assign_eq) ); auto with asmgen. @@ -649,8 +670,64 @@ Lemma exec_match_app: Proof. Admitted. +Lemma trans_arith_correct: + forall ge fn i rs m rs' s, + exec_arith_instr ge i rs m = rs' -> + match_states (State rs m) s -> + exists s', + macro_run (Genv ge fn) (trans_arith i) s s = Some s' + /\ match_states (State rs' m) s'. +Proof. +Admitted. + +Lemma forward_simu_basic: + forall ge fn b rs m rs' m' s, + exec_basic_instr ge b rs m = Next rs' m' -> + match_states (State rs m) s -> + exists s', + macro_run (Genv ge fn) (trans_basic b) s s = Some s' + /\ match_states (State rs' m') s'. +Proof. + intros. destruct b. +(* Arith *) + - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. +(* Load *) + - simpl in H. destruct i; destruct i. + all: unfold exec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; pose (H1 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| + Simpl| + intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); [ + subst; Simpl| + Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. +(* Store *) + - simpl in H. destruct i; destruct i. + all: unfold exec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; pose (H1 ra); simpl in e; rewrite e; pose (H1 rs0); simpl in e0; rewrite e0; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl]. +(* Allocframe *) + - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. + inv H. inv H0. eexists. split; try split. + * simpl. Simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite MEMAL. rewrite MEMS. Simpl. + rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]. + ** subst. Simpl. + ** subst. Simpl. + ** subst. Simpl. + ** Simpl. repeat (rewrite assign_diff). auto. + pose (not_eq_ireg_to_pos_ppos 3 GPR14 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos 3 GPR12 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos 3 GPR32 g). simpl ireg_to_pos in n2. auto. +Admitted. + Lemma forward_simu_body: - forall ge bdy rs m rs' m' fn s, + forall bdy ge rs m rs' m' fn s, Ge = Genv ge fn -> exec_body ge bdy rs m = Next rs' m' -> match_states (State rs m) s -> @@ -658,7 +735,15 @@ Lemma forward_simu_body: exec Ge (trans_body bdy) s = Some s' /\ match_states (State rs' m') s'. Proof. -Admitted. + induction bdy. + - intros. inv H1. simpl in *. inv H0. eexists. repeat (split; auto). + - intros until s. intros GE EXEB MS. simpl in EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + exploit forward_simu_basic; eauto. intros (s' & MRUN & MS'). subst Ge. + eapply IHbdy in MS'; eauto. destruct MS' as (s'' & EXECB & MS'). + eexists. split. + * simpl. rewrite MRUN. eassumption. + * eassumption. +Qed. Lemma forward_simu_control: forall ge fn ex b rs m rs2 m2 s, -- cgit From 110a4b5c58dbf966f4d76c12df5850aeb0392bca Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Feb 2019 17:21:36 +0100 Subject: forward_simu_basic prouvé --> à prouver, trans_arith_correct (Asmblockdeps) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockdeps.v | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6bfbc67b..0a311421 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -581,7 +581,7 @@ Definition trans_basic (b: basic) : macro := | Pallocframe sz pos => [(#FP, Name (#SP)); (#SP, Op (Allocframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (Name (#SP)) @ Name pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); - (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); + (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Old (Name pmem) @ Enil)); (#RTMP, Op (Constant Vundef) Enil)] | Pget rd ra => [(#rd, Name (#ra))] | Pset ra rd => [(#ra, Name (#rd))] @@ -724,7 +724,33 @@ Proof. pose (not_eq_ireg_to_pos_ppos 3 GPR14 g). simpl ireg_to_pos in n2. auto. pose (not_eq_ireg_to_pos_ppos 3 GPR12 g). simpl ireg_to_pos in n2. auto. pose (not_eq_ireg_to_pos_ppos 3 GPR32 g). simpl ireg_to_pos in n2. auto. -Admitted. +(* Freeframe *) + - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rs GPR12) eqn:SPeq; try discriminate. + destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv H0. + eexists. split; try split. + * simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. + Simpl. rewrite e. rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]. + ** subst. Simpl. + ** subst. Simpl. + ** subst. Simpl. + ** Simpl. repeat (rewrite assign_diff). auto. + unfold ppos. pose (not_3_plus_n (ireg_to_pos g)). destruct a as (A & _ & _). auto. + pose (not_eq_ireg_to_pos_ppos 3 GPR12 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos 3 GPR32 g). simpl ireg_to_pos in n2. auto. +(* Pget *) + - simpl in H. destruct rs0 eqn:rs0eq; try discriminate. inv H. inv H0. + eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd). + * subst. Simpl. + * Simpl. rewrite assign_diff; auto. unfold ppos. apply not_eq_ireg_to_pos. auto. +(* Pset *) + - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv H0. + eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. +(* Pnop *) + - simpl in H. inv H. inv H0. eexists. split; try split. assumption. assumption. +Qed. Lemma forward_simu_body: forall bdy ge rs m rs' m' fn s, -- cgit From 7e08f7bba8c36ded9d5787dd588336449ef1e62f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 25 Feb 2019 13:31:45 +0100 Subject: Finished the forward_simu of Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 96 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 90 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0a311421..72a9f342 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -567,9 +567,21 @@ Definition trans_arith (ai: ar_instruction) : macro := | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] - | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] - | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] - | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] + | PArithRRR n d s1 s2 => + match n with + | Pcompw _ | Pcompl _ => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Name pmem @ Enil))] + | _ => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] + end + | PArithRRI32 n d s i => + match n with + | Pcompiw _ => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Name pmem @ Enil))] + | _ => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] + end + | PArithRRI64 n d s i => + match n with + | Pcompil _ => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Name pmem @ Enil))] + | _ => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] + end end. @@ -639,6 +651,15 @@ Lemma not_eq_ireg_to_pos_ppos: Proof. Admitted. +Lemma not_eq_ireg_ppos: + forall r r', r <> r' -> (# r') <> (# r). +Proof. +Admitted. + +Lemma not_eq_IR: + forall r r', r <> r' -> IR r <> IR r'. +Proof. +Admitted. Ltac Simplif := ((rewrite nextblock_inv by eauto with asmgen) @@ -646,7 +667,7 @@ Ltac Simplif := || (rewrite Pregmap.gss) || (rewrite nextblock_pc) || (rewrite Pregmap.gso by eauto with asmgen) - || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not); try (apply not_3_plus_n))) + || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not); try (apply not_3_plus_n); try (apply not_eq_ireg_ppos; apply not_eq_IR; auto); try (apply not_eq_ireg_to_pos_ppos; auto))) || (rewrite assign_eq) ); auto with asmgen. @@ -678,7 +699,70 @@ Lemma trans_arith_correct: macro_run (Genv ge fn) (trans_arith i) s s = Some s' /\ match_states (State rs' m) s'. Proof. -Admitted. + intros. unfold exec_arith_instr in H. destruct i. +(* Ploadsymbol *) + - destruct i. inv H. inv H0. + eexists; split; try split. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRR *) + - destruct i. + all: inv H; inv H0; + eexists; split; try split; + [ simpl; pose (H1 rs0); simpl in e; rewrite e; reflexivity | + Simpl | + intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); subst; Simpl ]. +(* PArithRI32 *) + - destruct i. inv H. inv H0. + eexists; split; try split. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRI64 *) + - destruct i. inv H. inv H0. + eexists; split; try split. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF32 *) + - destruct i. inv H. inv H0. + eexists; split; try split. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF64 *) + - destruct i. inv H. inv H0. + eexists; split; try split. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRR *) + - destruct i. + all: inv H; inv H0; + eexists; split; try split; + [ simpl; pose (H1 rs1); simpl in e; rewrite e; pose (H1 rs2); simpl in e0; rewrite e0; try (rewrite H); reflexivity + | Simpl + | intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); subst; Simpl ]. +(* PArithRRI32 *) + - destruct i. + all: inv H; inv H0; + eexists; split; try split; + [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); reflexivity + | Simpl + | intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); subst; Simpl ]. +(* PArithRRI64 *) + - destruct i. + all: inv H; inv H0; + eexists; split; try split; + [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); reflexivity + | Simpl + | intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); subst; Simpl ]. +Qed. Lemma forward_simu_basic: forall ge fn b rs m rs' m' s, @@ -744,7 +828,7 @@ Proof. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. destruct (ireg_eq g rd). * subst. Simpl. - * Simpl. rewrite assign_diff; auto. unfold ppos. apply not_eq_ireg_to_pos. auto. + * Simpl. (* Pset *) - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. -- cgit From 9980f1ae211b04f568147b3c58897a9a1a121703 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 25 Feb 2019 15:29:33 +0100 Subject: Plugged Asmblockdeps into PostpassScheduling --- mppa_k1c/Asmblockdeps.v | 117 ++++- mppa_k1c/PostpassScheduling.v | 1052 ++++++++++++++++++-------------------- mppa_k1c/lib/Asmblockgenproof0.v | 8 +- 3 files changed, 605 insertions(+), 572 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 72a9f342..746e7b4c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -948,22 +948,101 @@ Proof. intros. unfold nextblock. destruct r; Simpl. Qed. -Theorem forward_simu: - forall rs1 m1 rs2 m2 s1' b ge fn, - Ge = Genv ge fn -> - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - match_states (State rs1 m1) s1' -> - exists s2', - exec Ge (trans_block b) s1' = Some s2' - /\ match_states (State rs2 m2) s2'. -Proof. - intros until fn. intros GENV EXECB MS. unfold exec_bblock in EXECB. destruct (exec_body _ _ _) eqn:EXEB; try discriminate. - exploit forward_simu_body; eauto. intros (s' & EXETRANSB & MS'). - exploit forward_simu_control; eauto. intros (s'' & EXETRANSEX & MS''). - - eexists. split. - unfold trans_block. eapply exec_match_app. eassumption. eassumption. - eassumption. -Qed. - -End SECT. +Theorem forward_simu: + forall rs1 m1 rs2 m2 s1' b ge fn, + Ge = Genv ge fn -> + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + match_states (State rs1 m1) s1' -> + exists s2', + exec Ge (trans_block b) s1' = Some s2' + /\ match_states (State rs2 m2) s2'. +Proof. + intros until fn. intros GENV EXECB MS. unfold exec_bblock in EXECB. destruct (exec_body _ _ _) eqn:EXEB; try discriminate. + exploit forward_simu_body; eauto. intros (s' & EXETRANSB & MS'). + exploit forward_simu_control; eauto. intros (s'' & EXETRANSEX & MS''). + + eexists. split. + unfold trans_block. eapply exec_match_app. eassumption. eassumption. + eassumption. +Qed. + +Axiom forward_simu_stuck: + forall rs1 m1 s1' b ge fn, + Ge = Genv ge fn -> + exec_bblock ge fn b rs1 m1 = Stuck -> + match_states (State rs1 m1) s1' -> + exec Ge (trans_block b) s1' = None. + +Axiom trans_block_reverse_stuck: + forall ge fn b rs m s', + Ge = Genv ge fn -> + exec Ge (trans_block b) s' = None -> + match_states (State rs m) s' -> + exec_bblock ge fn b rs m = Stuck. + +Axiom state_equiv: + forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. + +Axiom bblock_equiv_reduce: + forall p1 p2 ge fn, + Ge = Genv ge fn -> + L.bblock_equiv Ge (trans_block p1) (trans_block p2) -> + Asmblockgenproof0.bblock_equiv ge fn p1 p2. + +Definition string_of_name (x: P.R.t): ?? pstring := RET (Str ("resname")). +(* match x with + | xH => RET (Str ("the_mem")) + | _ as x => + DO s <~ string_of_Z (Zpos (Pos.pred x)) ;; + RET ("R" +; s) + end. *) + +Definition string_of_op (op: P.op): ?? pstring := RET (Str ("OP")). +(* match op with + | P.Imm i => + DO s <~ string_of_Z i ;; + RET s + | P.ARITH ADD => RET (Str "ADD") + | P.ARITH SUB => RET (Str "SUB") + | P.ARITH MUL => RET (Str "MUL") + | P.LOAD => RET (Str "LOAD") + | P.STORE => RET (Str "STORE") + end. *) + +Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := + if verb then + IDT.verb_bblock_eq_test string_of_name string_of_op Ge (trans_block p1) (trans_block p2) + else + IDT.bblock_eq_test Ge (trans_block p1) (trans_block p2). + +Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. + +Theorem bblock_eq_test_correct verb p1 p2 : + forall ge fn, Ge = Genv ge fn -> + WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. +Proof. + intros ge fn genv_eq. + wlp_simplify. +Admitted. +Global Opaque bblock_eq_test. +Hint Resolve bblock_eq_test_correct: wlp. + +Inductive bblock_equiv' (bb bb': L.bblock) := + | bblock_equiv_intro': + (forall s, exec Ge bb s = exec Ge bb' s) -> + bblock_equiv' bb bb'. + +Lemma bblock_equiv'_refl: forall tbb, bblock_equiv' tbb tbb. +Proof. + repeat constructor. +Qed. + +Axiom bblock_equivb: L.bblock -> L.bblock -> bool. + +Axiom bblock_equiv'_eq: + forall b1 b2, + bblock_equivb b1 b2 = true <-> bblock_equiv' b1 b2. + +End SECT. + +Extract Constant bblock_equivb => "PostpassSchedulingOracle.bblock_equivb'". diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 1b56d3ab..4464f1b2 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -12,6 +12,8 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. +Require Import Asmblockdeps Asmblockgenproof0. +Require Import ImpDep. Local Open Scope error_monad_scope. @@ -21,555 +23,501 @@ Axiom schedule: bblock -> list bblock. Extract Constant schedule => "PostpassSchedulingOracle.schedule". -(** Specification of the "coming soon" Asmblockdeps.v *) -Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - | bblock_equiv_intro: - (forall rs m, - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> - bblock_equiv ge f bb bb'. - -Axiom state': Type. -Definition outcome' := option state'. - -Axiom bblock': Type. -Extract Constant bblock' => "PostpassSchedulingOracle.bblock'". (* FIXME *) -Axiom exec': genv -> function -> bblock' -> state' -> outcome'. -Axiom match_states: state -> state' -> Prop. -Axiom trans_block: bblock -> bblock'. -Extract Constant trans_block => "PostpassSchedulingOracle.trans_block". (* FIXME *) -Axiom trans_state: state -> state'. - -Axiom trans_state_match: forall S, match_states S (trans_state S). - -Inductive bblock_equiv' (ge: Genv.t fundef unit) (f: function) (bb bb': bblock') := - | bblock_equiv_intro': - (forall s, - exec' ge f bb s = exec' ge f bb' s) -> - bblock_equiv' ge f bb bb'. - -Lemma bblock_equiv'_refl: forall ge fn tbb, bblock_equiv' ge fn tbb tbb. -Proof. - repeat constructor. -Qed. - - - -Definition exec := exec_bblock. - -Axiom forward_simu: - forall rs1 m1 rs2 m2 s1' b ge fn, - exec ge fn b rs1 m1 = Next rs2 m2 -> - match_states (State rs1 m1) s1' -> - exists s2', - exec' ge fn (trans_block b) s1' = Some s2' - /\ match_states (State rs2 m2) s2'. - -Axiom forward_simu_stuck: - forall rs1 m1 s1' b ge fn, - exec ge fn b rs1 m1 = Stuck -> - match_states (State rs1 m1) s1' -> - exec' ge fn (trans_block b) s1' = None. - -Axiom trans_block_reverse_stuck: - forall ge fn b rs m s', - exec' ge fn (trans_block b) s' = None -> - match_states (State rs m) s' -> - exec ge fn b rs m = Stuck. - -Axiom state_equiv: - forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. - - -(* TODO - replace it by the actual bblock_equivb' *) -Axiom bblock_equivb': bblock' -> bblock' -> bool. -Extract Constant bblock_equivb' => "PostpassSchedulingOracle.bblock_equivb'". (* FIXME *) - -Axiom bblock_equiv'_eq: - forall ge fn b1 b2, - bblock_equivb' b1 b2 = true <-> bblock_equiv' ge fn b1 b2. - -Lemma bblock_equivb'_refl: forall tbb, bblock_equivb' tbb tbb = true. -Proof. - intros. rewrite bblock_equiv'_eq. apply bblock_equiv'_refl. - Unshelve. (* FIXME - problem of Genv and function *) -Admitted. - - -Lemma trans_equiv_stuck: - forall b1 b2 ge fn rs m, - bblock_equiv' ge fn (trans_block b1) (trans_block b2) -> - (exec ge fn b1 rs m = Stuck <-> exec ge fn b2 rs m = Stuck). -Proof. - intros. inv H. - pose (trans_state_match (State rs m)). - split. - - intros. eapply forward_simu_stuck in H; eauto. rewrite H0 in H. eapply trans_block_reverse_stuck; eassumption. - - intros. eapply forward_simu_stuck in H; eauto. rewrite <- H0 in H. eapply trans_block_reverse_stuck; eassumption. -Qed. - - - -Lemma bblock_equiv'_comm: - forall ge fn b1 b2, - bblock_equiv' ge fn b1 b2 <-> bblock_equiv' ge fn b2 b1. -Proof. - intros. repeat constructor. all: inv H; congruence. -Qed. - -Theorem trans_exec: - forall b1 b2 ge f, bblock_equiv' ge f (trans_block b1) (trans_block b2) -> bblock_equiv ge f b1 b2. -Proof. - repeat constructor. intros rs1 m1. - destruct (exec_bblock _ _ b1 _ _) as [rs2 m2|] eqn:EXEB; destruct (exec_bblock _ _ b2 _ _) as [rs3 m3|] eqn:EXEB2; auto. - - pose (trans_state_match (State rs1 m1)). - exploit forward_simu. - eapply EXEB. - eapply m. - intros (s2' & EXEB' & MS). - exploit forward_simu. - eapply EXEB2. - eapply m. - intros (s3' & EXEB'2 & MS2). inv H. - rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. - exploit (state_equiv (State rs2 m2) (State rs3 m3) s2'). eauto. - congruence. - - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. unfold exec in EXEB2. rewrite EXEB2 in EXEB. discriminate. - - rewrite trans_equiv_stuck in EXEB; eauto. unfold exec in EXEB. rewrite EXEB in EXEB2. discriminate. -Qed. - - - -(* Lemmas necessary for defining concat_all *) -Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. -Proof. - intros. destruct l; simpl. - - contradiction. - - discriminate. -Qed. - -Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. -Proof. - destruct l. - - intros. simpl; auto. - - intros. rewrite <- app_comm_cons. discriminate. -Qed. - - - -Definition check_size bb := - if zlt Ptrofs.max_unsigned (size bb) - then Error (msg "PostpassSchedulingproof.check_size") - else OK tt. - -Program Definition concat2 (bb bb': bblock) : res bblock := - do ch <- check_size bb; - do ch' <- check_size bb'; - match (exit bb) with - | None => - match (header bb') with - | nil => - match (exit bb') with - | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") - | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end. -Next Obligation. - apply wf_bblock_refl. constructor. - - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. - inversion_clear WF'. inversion_clear WF. clear H1 H3. - inversion H2; inversion H0. - + left. apply app_nonil. auto. - + right. auto. - + left. apply app_nonil2. auto. - + right. auto. - - unfold builtin_alone. intros. rewrite H0 in H. - assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). - apply (H ef args res). contradict H1. auto. -Defined. - -Lemma concat2_zlt_size: - forall a b bb, - concat2 a b = OK bb -> - size a <= Ptrofs.max_unsigned - /\ size b <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. - split. - - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. - - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. -Qed. - -Lemma concat2_noexit: - forall a b bb, - concat2 a b = OK bb -> - exit a = None. -Proof. - intros. destruct a as [hd bdy ex WF]; simpl in *. - destruct ex as [e|]; simpl in *; auto. - unfold concat2 in H. simpl in H. monadInv H. -Qed. - -Lemma concat2_decomp: - forall a b bb, - concat2 a b = OK bb -> - body bb = body a ++ body b - /\ exit bb = exit b. -Proof. - intros. exploit concat2_noexit; eauto. intros. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. - subst exa. - unfold concat2 in H; simpl in H. - destruct hdb. - - destruct exb. - + destruct c. - * destruct i. monadInv H. - * monadInv H. split; auto. - + monadInv H. split; auto. - - monadInv H. -Qed. - -Lemma concat2_size: - forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. -Proof. - intros. unfold concat2 in H. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. - destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). - - destruct c. - + destruct i; try (monadInv EQ2). - + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. - - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. -Qed. - -Lemma concat2_header: - forall bb bb' tbb, - concat2 bb bb' = OK tbb -> header bb = header tbb. -Proof. - intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. - unfold concat2 in H. simpl in H. monadInv H. - destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. - - destruct c. - + destruct i; discriminate. - + congruence. - - congruence. -Qed. - -Lemma concat2_no_header_in_middle: - forall bb bb' tbb, - concat2 bb bb' = OK tbb -> - header bb' = nil. -Proof. - intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. - unfold concat2 in H. simpl in H. monadInv H. - destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. -Qed. - - - -Fixpoint concat_all (lbb: list bblock) : res bblock := - match lbb with - | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") - | bb::nil => OK bb - | bb::lbb => - do bb' <- concat_all lbb; - concat2 bb bb' - end. - -Lemma concat_all_size : - forall lbb a bb bb', - concat_all (a :: lbb) = OK bb -> - concat_all lbb = OK bb' -> - size bb = size a + size bb'. -Proof. - intros. unfold concat_all in H. fold concat_all in H. - destruct lbb; try discriminate. - monadInv H. rewrite H0 in EQ. inv EQ. - apply concat2_size. assumption. -Qed. - -Lemma concat_all_header: - forall lbb bb tbb, - concat_all (bb::lbb) = OK tbb -> header bb = header tbb. -Proof. - destruct lbb. - - intros. simpl in H. congruence. - - intros. simpl in H. destruct lbb. - + inv H. eapply concat2_header; eassumption. - + monadInv H. eapply concat2_header; eassumption. -Qed. - -Lemma concat_all_no_header_in_middle: - forall lbb tbb, - concat_all lbb = OK tbb -> - Forall (fun b => header b = nil) (tail lbb). -Proof. - induction lbb; intros; try constructor. - simpl. simpl in H. destruct lbb. - - constructor. - - monadInv H. simpl tl in IHlbb. constructor. - + apply concat2_no_header_in_middle in EQ0. apply concat_all_header in EQ. congruence. - + apply IHlbb in EQ. assumption. -Qed. - - - -Definition verify_schedule (bb bb' : bblock) : res unit := - match (bblock_equivb' (trans_block bb) (trans_block bb')) with - | true => OK tt - | false => Error (msg "PostpassScheduling.verify_schedule") - end. - -Lemma verify_schedule_refl: - forall bb, verify_schedule bb bb = OK tt. -Proof. - intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. -Qed. - - - -Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). - -Lemma verify_size_size: - forall bb lbb, verify_size bb lbb = OK tt -> size bb = size_blocks lbb. -Proof. - intros. unfold verify_size in H. destruct (size bb =? size_blocks lbb) eqn:SIZE; try discriminate. - apply Z.eqb_eq. assumption. -Qed. - - - -Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma no_header_size: - forall bb, size (no_header bb) = size bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. -Qed. - -Axiom trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. - -Lemma verify_schedule_no_header: - forall bb bb', - verify_schedule (no_header bb) bb' = verify_schedule bb bb'. -Proof. - intros. unfold verify_schedule. rewrite trans_block_noheader_inv. reflexivity. -Qed. - - - -Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Axiom trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. - -Lemma stick_header_size: - forall h bb, size (stick_header h bb) = size bb. -Proof. - intros. destruct bb. unfold stick_header. simpl. reflexivity. -Qed. - -Lemma stick_header_no_header: - forall bb, stick_header (header bb) (no_header bb) = bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. -Qed. - -Lemma stick_header_verify_schedule: - forall hd bb' hbb' bb, - stick_header hd bb' = hbb' -> - verify_schedule bb bb' = verify_schedule bb hbb'. -Proof. - intros. unfold verify_schedule. rewrite <- H. rewrite trans_block_header_inv. reflexivity. -Qed. - -Lemma check_size_stick_header: - forall bb hd, - check_size bb = check_size (stick_header hd bb). -Proof. - intros. unfold check_size. rewrite stick_header_size. reflexivity. -Qed. - -Lemma stick_header_concat2: - forall bb bb' hd tbb, - concat2 bb bb' = OK tbb -> - concat2 (stick_header hd bb) bb' = OK (stick_header hd tbb). -Proof. - intros. monadInv H. erewrite check_size_stick_header in EQ. - unfold concat2. rewrite EQ. rewrite EQ1. simpl. - destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. - destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. - - destruct c. - + destruct i. discriminate. - + inv EQ2. unfold stick_header; simpl. reflexivity. - - inv EQ2. unfold stick_header; simpl. reflexivity. -Qed. - -Lemma stick_header_concat_all: - forall bb c tbb hd, - concat_all (bb :: c) = OK tbb -> - concat_all (stick_header hd bb :: c) = OK (stick_header hd tbb). -Proof. - intros. simpl in *. destruct c; try congruence. - monadInv H. rewrite EQ. simpl. - apply stick_header_concat2. assumption. -Qed. - - - -Definition stick_header_code (h : list label) (lbb : list bblock) := - match (head lbb) with - | None => Error (msg "PostpassScheduling.stick_header: empty schedule") - | Some fst => OK ((stick_header h fst) :: tail lbb) - end. - -Lemma stick_header_code_no_header: - forall bb c, - stick_header_code (header bb) (no_header bb :: c) = OK (bb :: c). -Proof. - intros. unfold stick_header_code. simpl. rewrite stick_header_no_header. reflexivity. -Qed. - -Lemma hd_tl_size: - forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). -Proof. - destruct lbb. - - intros. simpl in H. discriminate. - - intros. simpl in H. inv H. simpl. reflexivity. -Qed. - -Lemma stick_header_code_size: - forall h lbb lbb', stick_header_code h lbb = OK lbb' -> size_blocks lbb = size_blocks lbb'. -Proof. - intros. unfold stick_header_code in H. destruct (hd_error lbb) eqn:HD; try discriminate. - inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. -Qed. - -Lemma stick_header_code_no_header_in_middle: - forall c h lbb, - stick_header_code h c = OK lbb -> - Forall (fun b => header b = nil) (tl c) -> - Forall (fun b => header b = nil) (tl lbb). -Proof. - destruct c; intros. - - unfold stick_header_code in H. simpl in H. discriminate. - - unfold stick_header_code in H. simpl in H. inv H. simpl in H0. - simpl. assumption. -Qed. - -Lemma stick_header_code_concat_all: - forall hd lbb hlbb tbb, - stick_header_code hd lbb = OK hlbb -> - concat_all lbb = OK tbb -> - exists htbb, - concat_all hlbb = OK htbb - /\ stick_header hd tbb = htbb. -Proof. - intros. exists (stick_header hd tbb). split; auto. - destruct lbb. - - unfold stick_header_code in H. simpl in H. discriminate. - - unfold stick_header_code in H. simpl in H. inv H. - apply stick_header_concat_all. assumption. -Qed. - - - -Definition do_schedule (bb: bblock) : list bblock := - if (Z.eqb (size bb) 1) then bb::nil else schedule bb. - -Definition verified_schedule (bb : bblock) : res (list bblock) := - let bb' := no_header bb in - let lbb := do_schedule bb' in - do tbb <- concat_all lbb; - do sizecheck <- verify_size bb lbb; - do schedcheck <- verify_schedule bb' tbb; - stick_header_code (header bb) lbb. - -Lemma verified_schedule_size: - forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. -Proof. - intros. monadInv H. erewrite <- stick_header_code_size; eauto. - apply verify_size_size. - destruct x0; try discriminate. assumption. -Qed. - -Lemma verified_schedule_single_inst: - forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). -Proof. - intros. unfold verified_schedule. - unfold do_schedule. rewrite no_header_size. rewrite H. simpl. - unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). rewrite verify_schedule_refl. simpl. - apply stick_header_code_no_header. - rewrite H. reflexivity. -Qed. - -Lemma verified_schedule_no_header_in_middle: - forall lbb bb, - verified_schedule bb = OK lbb -> - Forall (fun b => header b = nil) (tail lbb). -Proof. - intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. - eapply concat_all_no_header_in_middle. eassumption. -Qed. - -Lemma verified_schedule_header: - forall bb tbb lbb, - verified_schedule bb = OK (tbb :: lbb) -> - header bb = header tbb - /\ Forall (fun b => header b = nil) lbb. -Proof. - intros. split. - - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. - simpl. reflexivity. - - apply verified_schedule_no_header_in_middle in H. assumption. -Qed. - -Theorem verified_schedule_correct: - forall ge f bb lbb, - verified_schedule bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb - /\ bblock_equiv 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. - apply trans_exec. apply bblock_equiv'_eq. unfold verify_schedule in EQ0. - destruct (bblock_equivb' _ _); auto; try discriminate. -Qed. - - - -Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := - match lbb with - | nil => OK nil - | (cons bb lbb) => - do tlbb <- transf_blocks lbb; - do tbb <- verified_schedule bb; - OK (tbb ++ tlbb) - end. - -Definition transl_function (f: function) : res function := - do lb <- transf_blocks (fn_blocks f); - OK (mkfunction (fn_sig f) lb). - -Definition transf_function (f: function) : res function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: fundef) : res fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: program) : res program := - transform_partial_program transf_fundef p. \ No newline at end of file +Definition state' := L.mem. +Definition outcome' := option state'. + +Definition bblock' := L.bblock. + +Definition exec' := L.run. + +Definition exec := exec_bblock. + +Definition bblock_equivb' := bblock_equivb. + +Lemma bblock_equivb'_refl: forall tbb, bblock_equivb' tbb tbb = true. +Proof. + intros. rewrite bblock_equiv'_eq. apply bblock_equiv'_refl. + Unshelve. (* FIXME - problem of Genv and function *) +Admitted. + +Lemma trans_equiv_stuck: + forall b1 b2 ge fn rs m, + bblock_equiv' (P.Genv ge fn) (trans_block b1) (trans_block b2) -> + (exec ge fn b1 rs m = Stuck <-> exec ge fn b2 rs m = Stuck). +Proof. + intros. inv H. + pose (trans_state_match (State rs m)). + split. + - intros. eapply forward_simu_stuck in H; eauto. rewrite H0 in H. eapply trans_block_reverse_stuck. + reflexivity. eassumption. eassumption. + - intros. eapply forward_simu_stuck in H; eauto. rewrite <- H0 in H. eapply trans_block_reverse_stuck. + reflexivity. eassumption. eassumption. +Qed. + + +Lemma bblock_equiv'_comm: + forall ge fn b1 b2, + bblock_equiv' (P.Genv ge fn) b1 b2 <-> bblock_equiv' (P.Genv ge fn) b2 b1. +Proof. + intros. repeat constructor. all: inv H; congruence. +Qed. + +Theorem trans_exec: + forall b1 b2 ge f, bblock_equiv' (P.Genv ge f) (trans_block b1) (trans_block b2) -> bblock_equiv ge f b1 b2. +Proof. + repeat constructor. intros rs1 m1. + destruct (exec_bblock _ _ b1 _ _) as [rs2 m2|] eqn:EXEB; destruct (exec_bblock _ _ b2 _ _) as [rs3 m3|] eqn:EXEB2; auto. + - pose (trans_state_match (State rs1 m1)). + exploit forward_simu. + reflexivity. + eapply EXEB. + eapply m. + intros (s2' & EXEB' & MS). + exploit forward_simu. + reflexivity. + eapply EXEB2. + eapply m. + intros (s3' & EXEB'2 & MS2). inv H. + rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. + exploit (state_equiv (State rs2 m2) (State rs3 m3) s2'). eauto. + congruence. + - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. unfold exec in EXEB2. rewrite EXEB2 in EXEB. discriminate. + - rewrite trans_equiv_stuck in EXEB; eauto. unfold exec in EXEB. rewrite EXEB in EXEB2. discriminate. +Qed. + + + +(* Lemmas necessary for defining concat_all *) +Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. +Proof. + intros. destruct l; simpl. + - contradiction. + - discriminate. +Qed. + +Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. +Proof. + destruct l. + - intros. simpl; auto. + - intros. rewrite <- app_comm_cons. discriminate. +Qed. + + + +Definition check_size bb := + if zlt Ptrofs.max_unsigned (size bb) + then Error (msg "PostpassSchedulingproof.check_size") + else OK tt. + +Program Definition concat2 (bb bb': bblock) : res bblock := + do ch <- check_size bb; + do ch' <- check_size bb'; + match (exit bb) with + | None => + match (header bb') with + | nil => + match (exit bb') with + | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") + | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. + inversion_clear WF'. inversion_clear WF. clear H1 H3. + inversion H2; inversion H0. + + left. apply app_nonil. auto. + + right. auto. + + left. apply app_nonil2. auto. + + right. auto. + - unfold builtin_alone. intros. rewrite H0 in H. + assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). + apply (H ef args res). contradict H1. auto. +Defined. + +Lemma concat2_zlt_size: + forall a b bb, + concat2 a b = OK bb -> + size a <= Ptrofs.max_unsigned + /\ size b <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. + split. + - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. + - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. +Qed. + +Lemma concat2_noexit: + forall a b bb, + concat2 a b = OK bb -> + exit a = None. +Proof. + intros. destruct a as [hd bdy ex WF]; simpl in *. + destruct ex as [e|]; simpl in *; auto. + unfold concat2 in H. simpl in H. monadInv H. +Qed. + +Lemma concat2_decomp: + forall a b bb, + concat2 a b = OK bb -> + body bb = body a ++ body b + /\ exit bb = exit b. +Proof. + intros. exploit concat2_noexit; eauto. intros. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. + subst exa. + unfold concat2 in H; simpl in H. + destruct hdb. + - destruct exb. + + destruct c. + * destruct i. monadInv H. + * monadInv H. split; auto. + + monadInv H. split; auto. + - monadInv H. +Qed. + +Lemma concat2_size: + forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. +Proof. + intros. unfold concat2 in H. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. + destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). + - destruct c. + + destruct i; try (monadInv EQ2). + + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. + - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. +Qed. + +Lemma concat2_header: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> header bb = header tbb. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. + - destruct c. + + destruct i; discriminate. + + congruence. + - congruence. +Qed. + +Lemma concat2_no_header_in_middle: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> + header bb' = nil. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. +Qed. + + + +Fixpoint concat_all (lbb: list bblock) : res bblock := + match lbb with + | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") + | bb::nil => OK bb + | bb::lbb => + do bb' <- concat_all lbb; + concat2 bb bb' + end. + +Lemma concat_all_size : + forall lbb a bb bb', + concat_all (a :: lbb) = OK bb -> + concat_all lbb = OK bb' -> + size bb = size a + size bb'. +Proof. + intros. unfold concat_all in H. fold concat_all in H. + destruct lbb; try discriminate. + monadInv H. rewrite H0 in EQ. inv EQ. + apply concat2_size. assumption. +Qed. + +Lemma concat_all_header: + forall lbb bb tbb, + concat_all (bb::lbb) = OK tbb -> header bb = header tbb. +Proof. + destruct lbb. + - intros. simpl in H. congruence. + - intros. simpl in H. destruct lbb. + + inv H. eapply concat2_header; eassumption. + + monadInv H. eapply concat2_header; eassumption. +Qed. + +Lemma concat_all_no_header_in_middle: + forall lbb tbb, + concat_all lbb = OK tbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + induction lbb; intros; try constructor. + simpl. simpl in H. destruct lbb. + - constructor. + - monadInv H. simpl tl in IHlbb. constructor. + + apply concat2_no_header_in_middle in EQ0. apply concat_all_header in EQ. congruence. + + apply IHlbb in EQ. assumption. +Qed. + + + +Definition verify_schedule (bb bb' : bblock) : res unit := + match (bblock_equivb' (trans_block bb) (trans_block bb')) with + | true => OK tt + | false => Error (msg "PostpassScheduling.verify_schedule") + end. + +Lemma verify_schedule_refl: + forall bb, verify_schedule bb bb = OK tt. +Proof. + intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. +Qed. + + + +Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). + +Lemma verify_size_size: + forall bb lbb, verify_size bb lbb = OK tt -> size bb = size_blocks lbb. +Proof. + intros. unfold verify_size in H. destruct (size bb =? size_blocks lbb) eqn:SIZE; try discriminate. + apply Z.eqb_eq. assumption. +Qed. + + + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. +Qed. + +Axiom trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. + +Lemma verify_schedule_no_header: + forall bb bb', + verify_schedule (no_header bb) bb' = verify_schedule bb bb'. +Proof. + intros. unfold verify_schedule. rewrite trans_block_noheader_inv. reflexivity. +Qed. + + + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Axiom trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. +Qed. + +Lemma stick_header_verify_schedule: + forall hd bb' hbb' bb, + stick_header hd bb' = hbb' -> + verify_schedule bb bb' = verify_schedule bb hbb'. +Proof. + intros. unfold verify_schedule. rewrite <- H. rewrite trans_block_header_inv. reflexivity. +Qed. + +Lemma check_size_stick_header: + forall bb hd, + check_size bb = check_size (stick_header hd bb). +Proof. + intros. unfold check_size. rewrite stick_header_size. reflexivity. +Qed. + +Lemma stick_header_concat2: + forall bb bb' hd tbb, + concat2 bb bb' = OK tbb -> + concat2 (stick_header hd bb) bb' = OK (stick_header hd tbb). +Proof. + intros. monadInv H. erewrite check_size_stick_header in EQ. + unfold concat2. rewrite EQ. rewrite EQ1. simpl. + destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. + destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. + - destruct c. + + destruct i. discriminate. + + inv EQ2. unfold stick_header; simpl. reflexivity. + - inv EQ2. unfold stick_header; simpl. reflexivity. +Qed. + +Lemma stick_header_concat_all: + forall bb c tbb hd, + concat_all (bb :: c) = OK tbb -> + concat_all (stick_header hd bb :: c) = OK (stick_header hd tbb). +Proof. + intros. simpl in *. destruct c; try congruence. + monadInv H. rewrite EQ. simpl. + apply stick_header_concat2. assumption. +Qed. + + + +Definition stick_header_code (h : list label) (lbb : list bblock) := + match (head lbb) with + | None => Error (msg "PostpassScheduling.stick_header: empty schedule") + | Some fst => OK ((stick_header h fst) :: tail lbb) + end. + +Lemma stick_header_code_no_header: + forall bb c, + stick_header_code (header bb) (no_header bb :: c) = OK (bb :: c). +Proof. + intros. unfold stick_header_code. simpl. rewrite stick_header_no_header. reflexivity. +Qed. + +Lemma hd_tl_size: + forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). +Proof. + destruct lbb. + - intros. simpl in H. discriminate. + - intros. simpl in H. inv H. simpl. reflexivity. +Qed. + +Lemma stick_header_code_size: + forall h lbb lbb', stick_header_code h lbb = OK lbb' -> size_blocks lbb = size_blocks lbb'. +Proof. + intros. unfold stick_header_code in H. destruct (hd_error lbb) eqn:HD; try discriminate. + inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. +Qed. + +Lemma stick_header_code_no_header_in_middle: + forall c h lbb, + stick_header_code h c = OK lbb -> + Forall (fun b => header b = nil) (tl c) -> + Forall (fun b => header b = nil) (tl lbb). +Proof. + destruct c; intros. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. simpl in H0. + simpl. assumption. +Qed. + +Lemma stick_header_code_concat_all: + forall hd lbb hlbb tbb, + stick_header_code hd lbb = OK hlbb -> + concat_all lbb = OK tbb -> + exists htbb, + concat_all hlbb = OK htbb + /\ stick_header hd tbb = htbb. +Proof. + intros. exists (stick_header hd tbb). split; auto. + destruct lbb. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. + apply stick_header_concat_all. assumption. +Qed. + + + +Definition do_schedule (bb: bblock) : list bblock := + if (Z.eqb (size bb) 1) then bb::nil else schedule bb. + +Definition verified_schedule (bb : bblock) : res (list bblock) := + let bb' := no_header bb in + let lbb := do_schedule bb' in + do tbb <- concat_all lbb; + do sizecheck <- verify_size bb lbb; + do schedcheck <- verify_schedule bb' tbb; + stick_header_code (header bb) lbb. + +Lemma verified_schedule_size: + forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. +Proof. + intros. monadInv H. erewrite <- stick_header_code_size; eauto. + apply verify_size_size. + destruct x0; try discriminate. assumption. +Qed. + +Lemma verified_schedule_single_inst: + forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). +Proof. + intros. unfold verified_schedule. + unfold do_schedule. rewrite no_header_size. rewrite H. simpl. + unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). rewrite verify_schedule_refl. simpl. + apply stick_header_code_no_header. + rewrite H. reflexivity. +Qed. + +Lemma verified_schedule_no_header_in_middle: + forall lbb bb, + verified_schedule bb = OK lbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. + eapply concat_all_no_header_in_middle. eassumption. +Qed. + +Lemma verified_schedule_header: + forall bb tbb lbb, + verified_schedule bb = OK (tbb :: lbb) -> + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. +Proof. + intros. split. + - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. + simpl. reflexivity. + - apply verified_schedule_no_header_in_middle in H. assumption. +Qed. + +Theorem verified_schedule_correct: + forall ge f bb lbb, + verified_schedule bb = OK lbb -> + exists tbb, + concat_all lbb = OK tbb + /\ bblock_equiv 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. + apply trans_exec. apply bblock_equiv'_eq. unfold verify_schedule in EQ0. unfold bblock_equivb' in EQ0. + destruct (bblock_equivb _ _); auto; try discriminate. +Qed. + + + +Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := + match lbb with + | nil => OK nil + | (cons bb lbb) => + do tlbb <- transf_blocks lbb; + do tbb <- verified_schedule bb; + OK (tbb ++ tlbb) + end. + +Definition transl_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); + OK (mkfunction (fn_sig f) lb). + +Definition transf_function (f: function) : res function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 8c299f88..69234938 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -20,6 +20,12 @@ Module AB:=Asmblock. Hint Extern 2 (_ <> _) => congruence: asmgen. +Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + | bblock_equiv_intro: + (forall rs m, + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> + bblock_equiv ge f bb bb'. + Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. Proof. @@ -1096,4 +1102,4 @@ Proof. intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. Qed. -End MATCH_STACK. \ No newline at end of file +End MATCH_STACK. -- cgit From 2e8fdd34738f86e9f207fe9180896235b7ad47a6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 25 Feb 2019 17:36:14 +0100 Subject: Splitting trans_block_reverse_stuck into smaller lemmas --- mppa_k1c/Asmblockdeps.v | 81 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 73 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 746e7b4c..7eb1fd93 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -973,21 +973,86 @@ Axiom forward_simu_stuck: match_states (State rs1 m1) s1' -> exec Ge (trans_block b) s1' = None. -Axiom trans_block_reverse_stuck: - forall ge fn b rs m s', +Lemma exec_bblock_stuck_nec: + forall ge fn b rs m, + exec_body ge (body b) rs m = Stuck + \/ (exists rs' m', exec_body ge (body b) rs m = Next rs' m' /\ exec_control ge fn (exit b) (nextblock b rs') m' = Stuck) + -> exec_bblock ge fn b rs m = Stuck. +Proof. + intros. destruct H. + - unfold exec_bblock. rewrite H. reflexivity. + - destruct H as (rs' & m' & EXEB & EXEC). unfold exec_bblock. rewrite EXEB. assumption. +Qed. + +Lemma exec_body_next_exec: + forall ge fn b rs m rs' m' s, + Ge = Genv ge fn -> + exec_body ge (body b) rs m = Next rs' m' -> + match_states (State rs m) s -> + exists s', + match_states (State rs' m') s' + /\ exec Ge (trans_block b) s = exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s'. +Proof. +Admitted. + +Lemma exec_trans_pcincr_exec: + forall rs m s b, + match_states (State rs m) s -> + exists s', + match_states (State (nextblock b rs) m) s' + /\ exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s = exec Ge (trans_exit (exit b)) s'. +Proof. +Admitted. + +Lemma exec_exit_none: + forall ge fn rs m s ex, + Ge = Genv ge fn -> + match_states (State rs m) s -> + exec Ge (trans_exit ex) s = None -> + exec_control ge fn ex rs m = Stuck. +Proof. +Admitted. + +Theorem trans_block_reverse_stuck: + forall ge fn b rs m s, Ge = Genv ge fn -> - exec Ge (trans_block b) s' = None -> - match_states (State rs m) s' -> + exec Ge (trans_block b) s = None -> + match_states (State rs m) s -> exec_bblock ge fn b rs m = Stuck. +Proof. + intros until s. intros Geq EXECBK MS. + apply exec_bblock_stuck_nec. + destruct (exec_body _ _ _ _) eqn:EXEB. + - right. repeat eexists. + exploit exec_body_next_exec; eauto. + intros (s' & MS' & EXECBK'). rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. + exploit exec_trans_pcincr_exec; eauto. intros (s'' & MS'' & EXECINCR'). rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. + eapply exec_exit_none; eauto. + - left. reflexivity. +Qed. + -Axiom state_equiv: +Lemma state_eq_decomp: + forall rs1 m1 rs2 m2, rs1 = rs2 -> m1 = m2 -> State rs1 m1 = State rs2 m2. +Proof. + intros. congruence. +Qed. + +Theorem state_equiv: forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. +Proof. + intros. inv H. unfold match_states in H0, H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. + apply state_eq_decomp. + - apply functional_extensionality. intros. assert (Val (rs1 x) = Val (rs2 x)) by congruence. congruence. + - congruence. +Qed. + Axiom bblock_equiv_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_equiv Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_equiv ge fn p1 p2. + Asmblockgenproof0.bblock_equiv ge fn p1 p2. (* FIXME *) Definition string_of_name (x: P.R.t): ?? pstring := RET (Str ("resname")). (* match x with @@ -1023,7 +1088,7 @@ Theorem bblock_eq_test_correct verb p1 p2 : Proof. intros ge fn genv_eq. wlp_simplify. -Admitted. +Admitted. (* FIXME - à voir avec Sylvain *) Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. @@ -1041,7 +1106,7 @@ Axiom bblock_equivb: L.bblock -> L.bblock -> bool. Axiom bblock_equiv'_eq: forall b1 b2, - bblock_equivb b1 b2 = true <-> bblock_equiv' b1 b2. + bblock_equivb b1 b2 = true <-> bblock_equiv' b1 b2. (* FIXME - à voir avec Sylvain *) End SECT. -- cgit From 2fb2c3ef49bfa34d5ce2956a788425bf02e36f56 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 25 Feb 2019 17:59:59 +0100 Subject: Proving two lemmas of trans_block_reverse_stuck Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 51 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 46 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 7eb1fd93..8c53513d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -999,10 +999,15 @@ Lemma exec_trans_pcincr_exec: forall rs m s b, match_states (State rs m) s -> exists s', - match_states (State (nextblock b rs) m) s' - /\ exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s = exec Ge (trans_exit (exit b)) s'. + exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s = exec Ge (trans_exit (exit b)) s' + /\ match_states (State (nextblock b rs) m) s'. Proof. -Admitted. + intros. inv H. eexists. split. simpl. + unfold control_eval. pose (H1 PC); simpl in e; rewrite e. destruct Ge. reflexivity. + simpl. split. + - Simpl. + - intros rr; destruct rr; Simpl. +Qed. Lemma exec_exit_none: forall ge fn rs m s ex, @@ -1011,7 +1016,43 @@ Lemma exec_exit_none: exec Ge (trans_exit ex) s = None -> exec_control ge fn ex rs m = Stuck. Proof. -Admitted. + intros. inv H0. destruct ex as [ctl|]; try discriminate. + destruct ctl; destruct i; try reflexivity; try discriminate. +(* Pj_l *) + - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. + unfold goto_label_deps in H1. unfold goto_label. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. +(* Pcb *) + - simpl in *. destruct (cmp_for_btest bt). destruct i. + + pose (H3 PC); simpl in e; rewrite e in H1; clear e. + destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. + unfold eval_branch_deps in H1; unfold eval_branch. + destruct (Val.cmp_bool _ _ _); auto. destruct b; try discriminate. + unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + destruct (rs PC); auto. discriminate. + + pose (H3 PC); simpl in e; rewrite e in H1; clear e. + destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. + unfold eval_branch_deps in H1; unfold eval_branch. + destruct (Val.cmpl_bool _ _ _); auto. destruct b; try discriminate. + unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + destruct (rs PC); auto. discriminate. +(* Pcbu *) + - simpl in *. destruct (cmpu_for_btest bt). destruct i. + + pose (H3 PC); simpl in e; rewrite e in H1; clear e. + destruct o; auto. rewrite H2 in H1. + pose (H3 r); simpl in e; rewrite e in H1; clear e. + unfold eval_branch_deps in H1; unfold eval_branch. + destruct (Val.cmpu_bool _ _ _ _); auto. destruct b; try discriminate. + unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + destruct (rs PC); auto. discriminate. + + pose (H3 PC); simpl in e; rewrite e in H1; clear e. + destruct o; auto. rewrite H2 in H1. + pose (H3 r); simpl in e; rewrite e in H1; clear e. + unfold eval_branch_deps in H1; unfold eval_branch. + destruct (Val.cmplu_bool _ _ _); auto. destruct b; try discriminate. + unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + destruct (rs PC); auto. discriminate. +Qed. Theorem trans_block_reverse_stuck: forall ge fn b rs m s, @@ -1026,7 +1067,7 @@ Proof. - right. repeat eexists. exploit exec_body_next_exec; eauto. intros (s' & MS' & EXECBK'). rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. - exploit exec_trans_pcincr_exec; eauto. intros (s'' & MS'' & EXECINCR'). rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. + exploit exec_trans_pcincr_exec; eauto. intros (s'' & EXECINCR' & MS''). rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. eapply exec_exit_none; eauto. - left. reflexivity. Qed. -- cgit From fdc268af6a85aa27931373344c5f47152c086318 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Feb 2019 14:53:18 +0100 Subject: Finished trans_block_reverse_stuck --- mppa_k1c/Asmblockdeps.v | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 8c53513d..77159b2e 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -984,16 +984,36 @@ Proof. - destruct H as (rs' & m' & EXEB & EXEC). unfold exec_bblock. rewrite EXEB. assumption. Qed. +Lemma exec_basic_instr_next_exec: + forall ge fn i rs m rs' m' s tc, + Ge = Genv ge fn -> + exec_basic_instr ge i rs m = Next rs' m' -> + match_states (State rs m) s -> + exists s', + exec Ge (trans_basic i :: tc) s = exec Ge tc s' + /\ match_states (State rs' m') s'. +Proof. + intros. exploit forward_simu_basic; eauto. + intros (s' & MRUN & MS'). + simpl exec. exists s'. subst. rewrite MRUN. split; auto. +Qed. + Lemma exec_body_next_exec: - forall ge fn b rs m rs' m' s, + forall c ge fn rs m rs' m' s tc, Ge = Genv ge fn -> - exec_body ge (body b) rs m = Next rs' m' -> + exec_body ge c rs m = Next rs' m' -> match_states (State rs m) s -> exists s', - match_states (State rs' m') s' - /\ exec Ge (trans_block b) s = exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s'. + exec Ge (trans_body c ++ tc) s = exec Ge tc s' + /\ match_states (State rs' m') s'. Proof. -Admitted. + induction c. + - intros. simpl in H0. inv H0. simpl. exists s. split; auto. + - intros. simpl in H0. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + exploit exec_basic_instr_next_exec; eauto. intros (s' & EXEGEBASIC & MS'). + simpl trans_body. rewrite <- app_comm_cons. rewrite EXEGEBASIC. + eapply IHc; eauto. +Qed. Lemma exec_trans_pcincr_exec: forall rs m s b, @@ -1066,7 +1086,7 @@ Proof. destruct (exec_body _ _ _ _) eqn:EXEB. - right. repeat eexists. exploit exec_body_next_exec; eauto. - intros (s' & MS' & EXECBK'). rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. + intros (s' & EXECBK' & MS'). unfold trans_block in EXECBK. rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. exploit exec_trans_pcincr_exec; eauto. intros (s'' & EXECINCR' & MS''). rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. eapply exec_exit_none; eauto. - left. reflexivity. -- cgit From 468dad1d2046a9da64de4bf4fc33f0efafaca14d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Feb 2019 16:19:59 +0100 Subject: Proved forward_simu_stuck in Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 147 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 132 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 77159b2e..f527b54c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -84,6 +84,7 @@ Inductive op_wrap := | Freeframe (sz: Z) (pos: ptrofs) | Freeframe2 (sz: Z) (pos: ptrofs) | Constant (v: val) + | Fail . Coercion Arith: arith_op >-> op_wrap. @@ -363,6 +364,7 @@ Definition op_eval (o: op) (l: list value) := end end | Constant v, [] => Some (Val v) + | Fail, _ => None | _, _ => None end. @@ -451,6 +453,7 @@ Definition op_eq (o1 o2: op): ?? bool := | Freeframe sz1 pos1, Freeframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) | Freeframe2 sz1 pos1, Freeframe2 sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) | Constant c1, Constant c2 => phys_eq c1 c2 + | Fail, Fail => RET true | _, _ => RET false end. @@ -595,8 +598,14 @@ Definition trans_basic (b: basic) : macro := | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Old (Name pmem) @ Enil)); (#RTMP, Op (Constant Vundef) Enil)] - | Pget rd ra => [(#rd, Name (#ra))] - | Pset ra rd => [(#ra, Name (#rd))] + | Pget rd ra => match ra with + | RA => [(#rd, Name (#ra))] + | _ => [(#rd, Op Fail Enil)] + end + | Pset ra rd => match ra with + | RA => [(#ra, Name (#rd))] + | _ => [(#rd, Op Fail Enil)] + end | Pnop => [] end. @@ -683,7 +692,7 @@ Proof. destruct g; reflexivity. Qed. -Lemma exec_match_app: +Lemma exec_app_some: forall c c' s s' s'', exec Ge c s = Some s' -> exec Ge c' s' = Some s'' -> @@ -691,6 +700,13 @@ Lemma exec_match_app: Proof. Admitted. +Lemma exec_app_none: + forall c c' s, + exec Ge c s = None -> + exec Ge (c ++ c') s = None. +Proof. +Admitted. + Lemma trans_arith_correct: forall ge fn i rs m rs' s, exec_arith_instr ge i rs m = rs' -> @@ -962,26 +978,23 @@ Proof. exploit forward_simu_control; eauto. intros (s'' & EXETRANSEX & MS''). eexists. split. - unfold trans_block. eapply exec_match_app. eassumption. eassumption. + unfold trans_block. eapply exec_app_some. eassumption. eassumption. eassumption. Qed. -Axiom forward_simu_stuck: - forall rs1 m1 s1' b ge fn, - Ge = Genv ge fn -> - exec_bblock ge fn b rs1 m1 = Stuck -> - match_states (State rs1 m1) s1' -> - exec Ge (trans_block b) s1' = None. - Lemma exec_bblock_stuck_nec: forall ge fn b rs m, exec_body ge (body b) rs m = Stuck \/ (exists rs' m', exec_body ge (body b) rs m = Next rs' m' /\ exec_control ge fn (exit b) (nextblock b rs') m' = Stuck) - -> exec_bblock ge fn b rs m = Stuck. + <-> exec_bblock ge fn b rs m = Stuck. Proof. - intros. destruct H. - - unfold exec_bblock. rewrite H. reflexivity. - - destruct H as (rs' & m' & EXEB & EXEC). unfold exec_bblock. rewrite EXEB. assumption. + intros. split. + + intros. destruct H. + - unfold exec_bblock. rewrite H. reflexivity. + - destruct H as (rs' & m' & EXEB & EXEC). unfold exec_bblock. rewrite EXEB. assumption. + + intros. unfold exec_bblock in H. destruct (exec_body _ _ _ _) eqn:EXEB. + - right. repeat eexists. assumption. + - left. reflexivity. Qed. Lemma exec_basic_instr_next_exec: @@ -1092,6 +1105,110 @@ Proof. - left. reflexivity. Qed. +Lemma forward_simu_basic_instr_stuck: + forall i ge fn rs m s, + Ge = Genv ge fn -> + exec_basic_instr ge i rs m = Stuck -> + match_states (State rs m) s -> + exec Ge [trans_basic i] s = None. +Proof. + intros. inv H1. unfold exec_basic_instr in H0. destruct i; try discriminate. +(* PLoad *) + - destruct i; destruct i. + all: simpl; rewrite H2; pose (H3 ra); simpl in e; rewrite e; clear e; + unfold exec_load in H0; destruct (eval_offset _ _); auto; destruct (Mem.loadv _ _ _); auto; discriminate. +(* PStore *) + - destruct i; destruct i; + simpl; rewrite H2; pose (H3 ra); simpl in e; rewrite e; clear e; pose (H3 rs0); simpl in e; rewrite e; clear e; + unfold exec_store in H0; destruct (eval_offset _ _); auto; destruct (Mem.storev _ _ _); auto; discriminate. +(* Pallocframe *) + - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. destruct (Mem.alloc _ _ _). simpl in H0. + destruct (Mem.store _ _ _ _); try discriminate. reflexivity. +(* Pfreeframe *) + - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. + destruct (Mem.loadv _ _ _); auto. destruct (rs GPR12); auto. destruct (Mem.free _ _ _ _); auto. + discriminate. +(* Pget *) + - simpl. destruct rs0; subst; try discriminate. + all: simpl; auto. + - simpl. destruct rd; subst; try discriminate. + all: simpl; auto. +Qed. + +Lemma forward_simu_body_stuck: + forall bdy ge fn rs m s, + Ge = Genv ge fn -> + exec_body ge bdy rs m = Stuck -> + match_states (State rs m) s -> + exec Ge (trans_body bdy) s = None. +Proof. + induction bdy. + - simpl. discriminate. + - intros. simpl trans_body. simpl in H0. + destruct (exec_basic_instr _ _ _ _) eqn:EBI. + + exploit exec_basic_instr_next_exec; eauto. intros (s' & EXEGEB & MS'). rewrite EXEGEB. eapply IHbdy; eauto. + + cutrewrite (trans_basic a :: trans_body bdy = (trans_basic a :: nil) ++ trans_body bdy); try reflexivity. apply exec_app_none. + eapply forward_simu_basic_instr_stuck; eauto. +Qed. + + +Lemma forward_simu_exit_stuck: + forall ex ge fn rs m s, + Ge = Genv ge fn -> + exec_control ge fn ex rs m = Stuck -> + match_states (State rs m) s -> + exec Ge (trans_exit ex) s = None. +Proof. + intros. inv H1. destruct ex as [ctl|]; try discriminate. + destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). +(* Pj_l *) + - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold goto_label in H0. + destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. +(* Pcb *) + - simpl in *. destruct (cmp_for_btest bt). destruct i. + -- destruct o. + + unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmp_bool _ _ _); auto. + destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. + -- destruct o. + + unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmpl_bool _ _ _); auto. + destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. +(* Pcbu *) + - simpl in *. destruct (cmpu_for_btest bt). destruct i. + -- destruct o. + + rewrite H2. unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmpu_bool _ _ _); auto. + destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + + rewrite H2. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. + -- destruct o. + + rewrite H2. unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmplu_bool _ _ _); auto. + destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + + rewrite H2. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. +Qed. + + +Theorem forward_simu_stuck: + forall rs1 m1 s1' b ge fn, + Ge = Genv ge fn -> + exec_bblock ge fn b rs1 m1 = Stuck -> + match_states (State rs1 m1) s1' -> + exec Ge (trans_block b) s1' = None. +Proof. + intros until fn. intros GENV EXECB MS. apply exec_bblock_stuck_nec in EXECB. destruct EXECB. + - unfold trans_block. apply exec_app_none. eapply forward_simu_body_stuck; eauto. + - destruct H as (rs' & m' & EXEB & EXEC). unfold trans_block. exploit exec_body_next_exec; eauto. + intros (s' & EXEGEBODY & MS'). rewrite EXEGEBODY. exploit exec_trans_pcincr_exec; eauto. + intros (s'' & EXEGEPC & MS''). rewrite EXEGEPC. eapply forward_simu_exit_stuck; eauto. +Qed. + Lemma state_eq_decomp: forall rs1 m1 rs2 m2, rs1 = rs2 -> m1 = m2 -> State rs1 m1 = State rs2 m2. -- cgit From f53940eee66f08f069ee7163ad7cdeb80b483240 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 10:30:38 +0100 Subject: Proving a few more lemmas Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 53 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 38 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index f527b54c..a57f4241 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -650,25 +650,42 @@ Proof. all: destruct n; simpl; try (destruct n; discriminate); try discriminate. Qed. -Lemma not_eq_ireg_to_pos: - forall n r r', r' <> r -> n + ireg_to_pos r <> n + ireg_to_pos r'. +Lemma not_eq_add: + forall k n n', n <> n' -> k + n <> k + n'. Proof. -Admitted. +Admitted. (* FIXME - help Sylvain ? *) -Lemma not_eq_ireg_to_pos_ppos: - forall n r r', r' <> r -> n + ireg_to_pos r <> # r'. +Lemma not_eq_ireg_to_pos: + forall n r r', r' <> r -> n + ireg_to_pos r <> n + ireg_to_pos r'. Proof. -Admitted. + intros. destruct r; destruct r'; try contradiction; apply not_eq_add; discriminate. (* FIXME - quite long to prove *) +Qed. Lemma not_eq_ireg_ppos: forall r r', r <> r' -> (# r') <> (# r). Proof. -Admitted. + intros. unfold ppos. destruct r. + - destruct r'; try discriminate. + + apply not_eq_ireg_to_pos; congruence. + + destruct g; discriminate. + + destruct g; discriminate. + - destruct r'; try discriminate; try contradiction. + destruct g; discriminate. + - destruct r'; try discriminate; try contradiction. + destruct g; discriminate. +Qed. + +Lemma not_eq_ireg_to_pos_ppos: + forall r r', r' <> r -> 3 + ireg_to_pos r <> # r'. +Proof. + intros. unfold ppos. apply not_eq_ireg_to_pos. assumption. +Qed. Lemma not_eq_IR: forall r r', r <> r' -> IR r <> IR r'. Proof. -Admitted. + intros. congruence. +Qed. Ltac Simplif := ((rewrite nextblock_inv by eauto with asmgen) @@ -698,14 +715,20 @@ Lemma exec_app_some: exec Ge c' s' = Some s'' -> exec Ge (c ++ c') s = Some s''. Proof. -Admitted. + induction c. + - simpl. intros. congruence. + - intros. simpl in *. destruct (macro_run _ _ _ _); auto. eapply IHc; eauto. discriminate. +Qed. Lemma exec_app_none: forall c c' s, exec Ge c s = None -> exec Ge (c ++ c') s = None. Proof. -Admitted. + induction c. + - simpl. discriminate. + - intros. simpl. simpl in H. destruct (macro_run _ _ _ _); auto. +Qed. Lemma trans_arith_correct: forall ge fn i rs m rs' s, @@ -821,9 +844,9 @@ Proof. ** subst. Simpl. ** subst. Simpl. ** Simpl. repeat (rewrite assign_diff). auto. - pose (not_eq_ireg_to_pos_ppos 3 GPR14 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos 3 GPR12 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos 3 GPR32 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos GPR14 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos GPR12 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos GPR32 g). simpl ireg_to_pos in n2. auto. (* Freeframe *) - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rs GPR12) eqn:SPeq; try discriminate. destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv H0. @@ -837,8 +860,8 @@ Proof. ** subst. Simpl. ** Simpl. repeat (rewrite assign_diff). auto. unfold ppos. pose (not_3_plus_n (ireg_to_pos g)). destruct a as (A & _ & _). auto. - pose (not_eq_ireg_to_pos_ppos 3 GPR12 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos 3 GPR32 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos GPR12 g). simpl ireg_to_pos in n2. auto. + pose (not_eq_ireg_to_pos_ppos GPR32 g). simpl ireg_to_pos in n2. auto. (* Pget *) - simpl in H. destruct rs0 eqn:rs0eq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. -- cgit From 534fefe3cd7208eb9b3e931f36de36af3e420eb5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 11:00:35 +0100 Subject: Proving the trans_block_header axioms --- mppa_k1c/Asmblock.v | 30 + mppa_k1c/Asmblockdeps.v | 10 + mppa_k1c/PostpassScheduling.v | 48 +- mppa_k1c/PostpassSchedulingproof.v | 1344 ++++++++++++++++++------------------ 4 files changed, 719 insertions(+), 713 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index b9c50517..cade1ba8 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -578,6 +578,36 @@ Proof. - destruct e; simpl; try omega. contradict H; simpl; auto. *)Qed. + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. +Qed. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. +Qed. + + Definition bblocks := list bblock. Fixpoint size_blocks (l: bblocks): Z := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a57f4241..4d1a0d38 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -620,6 +620,16 @@ Definition trans_pcincr (sz: Z) := [(#PC, Op (Control (OIncremPC sz)) (Name (#PC Definition trans_block (b: Asmblock.bblock) : L.bblock := trans_body (body b) ++ trans_pcincr (size b) ++ trans_exit (exit b). +Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. +Proof. + intros. destruct bb as [hd bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. +Qed. + +Theorem trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. +Proof. + intros. destruct bb as [hdr bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. +Qed. + Definition state := L.mem. Definition exec := L.run. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 4464f1b2..6bf97279 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -34,11 +34,12 @@ Definition exec := exec_bblock. Definition bblock_equivb' := bblock_equivb. -Lemma bblock_equivb'_refl: forall tbb, bblock_equivb' tbb tbb = true. +Lemma bblock_equivb'_refl (ge: Genv.t fundef unit) (fn: function): forall tbb, bblock_equivb' tbb tbb = true. Proof. intros. rewrite bblock_equiv'_eq. apply bblock_equiv'_refl. Unshelve. (* FIXME - problem of Genv and function *) -Admitted. + constructor; auto. +Qed. Lemma trans_equiv_stuck: forall b1 b2 ge fn rs m, @@ -270,10 +271,10 @@ Definition verify_schedule (bb bb' : bblock) : res unit := | false => Error (msg "PostpassScheduling.verify_schedule") end. -Lemma verify_schedule_refl: +Lemma verify_schedule_refl (ge: Genv.t fundef unit) (fn: function): forall bb, verify_schedule bb bb = OK tt. Proof. - intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. + intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. all: auto. Qed. @@ -287,21 +288,6 @@ Proof. apply Z.eqb_eq. assumption. Qed. - - -Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma no_header_size: - forall bb, size (no_header bb) = size bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. -Qed. - -Axiom trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. - Lemma verify_schedule_no_header: forall bb bb', verify_schedule (no_header bb) bb' = verify_schedule bb bb'. @@ -310,26 +296,6 @@ Proof. Qed. - -Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Axiom trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. - -Lemma stick_header_size: - forall h bb, size (stick_header h bb) = size bb. -Proof. - intros. destruct bb. unfold stick_header. simpl. reflexivity. -Qed. - -Lemma stick_header_no_header: - forall bb, stick_header (header bb) (no_header bb) = bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. -Qed. - Lemma stick_header_verify_schedule: forall hd bb' hbb' bb, stick_header hd bb' = hbb' -> @@ -448,13 +414,13 @@ Proof. destruct x0; try discriminate. assumption. Qed. -Lemma verified_schedule_single_inst: +Lemma verified_schedule_single_inst (ge: Genv.t fundef unit) (fn: function): forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). Proof. intros. unfold verified_schedule. unfold do_schedule. rewrite no_header_size. rewrite H. simpl. unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). rewrite verify_schedule_refl. simpl. - apply stick_header_code_no_header. + apply stick_header_code_no_header. all: auto. rewrite H. reflexivity. Qed. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2c3b8454..2ecb494d 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -10,675 +10,675 @@ (* *) (* *********************************************************************) -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 PostpassScheduling. -Require Import Asmblockgenproof. -Require Import Axioms. - -Local Open Scope error_monad_scope. - -Definition match_prog (p tp: Asmblock.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. - -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 verified_schedule_builtin_idem: - forall bb ef args res lbb, - exit bb = Some (PExpand (Pbuiltin ef args res)) -> - verified_schedule bb = OK lbb -> - lbb = bb :: nil. -Proof. - intros. exploit builtin_body_nil; eauto. intros. - rewrite verified_schedule_single_inst in H0. - - inv H0. auto. - - unfold size. rewrite H. rewrite H1. simpl. auto. -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 {A: Type}: - forall (rs rs':A) m m', - rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - intros. congruence. -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). -Proof. - intros. apply functional_extensionality. intros. destruct (preg_eq r x). - - subst r. repeat (rewrite Pregmap.gss; auto). - - repeat (rewrite Pregmap.gso); auto. -Qed. - -Lemma exec_load_pc_var: - forall ge t rs m rd ra ofs rs' m' v, - exec_load ge t rs m rd ra ofs = Next rs' m' -> - exec_load ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge 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_store_pc_var: - forall ge t rs m rd ra ofs rs' m' v, - exec_store ge t rs m rd ra ofs = Next rs' m' -> - exec_store ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); 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 *. 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). - - exploreInst; apply exec_load_pc_var; auto. - - exploreInst; apply exec_store_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 GPR14 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' -> - exec_body ge l (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - induction l. - - intros. simpl. simpl in H. inv H. auto. - - intros. simpl in *. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI; try discriminate. - erewrite exec_basic_instr_pc_var; eauto. -Qed. - -Lemma pc_set_add: - forall rs v r x y, - 0 <= x <= Ptrofs.max_unsigned -> - 0 <= y <= Ptrofs.max_unsigned -> - rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). -Proof. - intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). - - 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. - unfold Ptrofs.add. - cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. - repeat (rewrite Ptrofs.unsigned_repr); auto. - - repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma concat2_straight: - forall a b bb rs m rs'' m'' f ge, - concat2 a b = OK bb -> - exec_bblock ge f bb rs m = Next rs'' m'' -> - exists rs' m', - exec_bblock ge f a rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) - /\ exec_bblock ge f b rs' m' = Next rs'' m''. -Proof. - intros until ge. intros CONC2 EXEB. - exploit concat2_zlt_size; eauto. intros (LTA & LTB). - exploit concat2_noexit; eauto. intros EXA. - exploit concat2_decomp; eauto. intros. inv H. - unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. - rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. - unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. - exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. - unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. - rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. - assert (size bb = size a + size b). - { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. - repeat (rewrite Nat2Z.inj_add). omega. } - clear EXA H0 H1. rewrite H in EXEB. - assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } - rewrite H0. rewrite <- pc_set_add; auto. - exploit AB.size_positive. instantiate (1 := a). intro. omega. - exploit AB.size_positive. instantiate (1 := b). intro. omega. -Qed. - -Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : - forall a bb rs m lbb rs'' m'', - lbb <> nil -> - concat_all (a :: lbb) = OK bb -> - exec_bblock ge f bb rs m = Next rs'' m'' -> - exists bb' rs' m', - concat_all lbb = OK bb' - /\ exec_bblock ge f a rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) - /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. -Proof. - intros until m''. intros Hnonil CONC EXEB. - simpl in CONC. - destruct lbb as [|b lbb]; try contradiction. clear Hnonil. - monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). - exists x. repeat econstructor. all: eauto. -Qed. - -Lemma ptrofs_add_repr : - forall a b, - Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). -Proof. - intros a b. - rewrite Ptrofs.add_unsigned. repeat (rewrite Ptrofs.unsigned_repr_eq). - rewrite <- Zplus_mod. auto. -Qed. - -Section PRESERVATION. - -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -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. - -Lemma symbols_preserved: - forall id, - Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_match TRANSL). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSL). - -Lemma functions_translated: - forall v f, - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial TRANSL). - -Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> - exists tf, - Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSL). - -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 function_ptr_translated; eauto. - intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. -Qed. - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall s1 s2, s1 = s2 -> match_states s1 s2. - -Lemma prog_main_preserved: - prog_main tprog = prog_main prog. -Proof (match_program_main TRANSL). - -Lemma prog_main_address_preserved: - (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = - (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). -Proof. - unfold Genv.symbol_address. rewrite symbols_preserved. - rewrite prog_main_preserved. auto. -Qed. - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> - exists st2, initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inv H. - econstructor; split. - - eapply initial_state_intro. - eapply (Genv.init_mem_transf_partial TRANSL); eauto. - - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> final_state st1 r -> final_state st2 r. -Proof. - intros. inv H0. inv H. econstructor; eauto. -Qed. - -Lemma tail_find_bblock: - forall lbb pos bb, - find_bblock pos lbb = Some bb -> - exists c, code_tail pos lbb (bb::c). -Proof. - induction lbb. - - intros. simpl in H. inv H. - - intros. simpl in H. - destruct (zlt pos 0); try (inv H; fail). - 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. - omega. -Qed. - -Lemma code_tail_head_app: - forall l pos c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + size_blocks l) (l++c1) c2. -Proof. - induction l. - - intros. simpl. rewrite Z.add_0_r. auto. - - intros. apply IHl in H. simpl. rewrite (Z.add_comm (size a)). rewrite Z.add_assoc. apply code_tail_S. assumption. -Qed. - -Lemma transf_blocks_verified: - forall c tc pos bb c', - transf_blocks c = OK tc -> - code_tail pos c (bb::c') -> - exists lbb, - verified_schedule bb = OK lbb - /\ exists tc', code_tail pos tc (lbb ++ tc'). -Proof. - induction c; intros. - - simpl in H. inv H. inv H0. - - inv H0. - + monadInv H. exists x0. - split; simpl; auto. eexists; eauto. econstructor; eauto. - + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. - exploit IHc; eauto. - intros (lbb & TRANS & tc' & TAIL). -(* monadInv TRANS. *) - repeat eexists; eauto. - erewrite verified_schedule_size; eauto. - apply code_tail_head_app. - eauto. -Qed. - -Lemma transf_find_bblock: - forall ofs f bb tf, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> - transf_function f = OK tf -> - exists lbb, - verified_schedule bb = OK lbb - /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). -Proof. - intros. - monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. - monadInv EQ. apply tail_find_bblock in H. destruct H as (c & TAIL). - eapply transf_blocks_verified; eauto. -Qed. - -Lemma symbol_address_preserved: - forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. -Proof. - intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. -Qed. - -Lemma head_tail {A: Type}: - forall (l: list A) hd, hd::l = hd :: (tail (hd::l)). -Proof. - intros. simpl. auto. -Qed. - -Lemma verified_schedule_not_empty: - forall bb lbb, - verified_schedule bb = OK lbb -> lbb <> nil. -Proof. - intros. apply verified_schedule_size in H. - pose (size_positive bb). assert (size_blocks lbb > 0) by omega. clear H g. - destruct lbb; simpl in *; discriminate. -Qed. - -Lemma header_nil_label_pos_none: - forall lbb l p, - Forall (fun b => header b = nil) lbb -> label_pos l p lbb = None. -Proof. - induction lbb. - - intros. simpl. auto. - - intros. inv H. simpl. unfold is_label. rewrite H2. destruct (in_dec l nil). { inv i. } - auto. -Qed. - -Lemma verified_schedule_label: - forall bb tbb lbb l, - verified_schedule bb = OK (tbb :: lbb) -> - is_label l bb = is_label l tbb - /\ label_pos l 0 lbb = None. -Proof. - intros. exploit verified_schedule_header; eauto. - intros (HdrEq & HdrNil). - split. - - unfold is_label. rewrite HdrEq. reflexivity. - - apply header_nil_label_pos_none. assumption. -Qed. - -Lemma label_pos_app_none: - forall c c' l p p', - label_pos l p c = None -> - label_pos l (p' + size_blocks c) c' = label_pos l p' (c ++ c'). -Proof. - induction c. - - intros. simpl in *. rewrite Z.add_0_r. reflexivity. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLABEL. - + discriminate. - + eapply IHc in H. rewrite Z.add_assoc. eauto. -Qed. - -Remark label_pos_pvar_none_add: - forall tc l p p' k, - label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. -Proof. - induction tc. - - intros. simpl. auto. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + discriminate. - + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar_none: - forall tc l p p', - label_pos l p tc = None -> label_pos l p' tc = None. -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_none_add; eauto. -Qed. - -Remark label_pos_pvar_some_add_add: - forall tc l p p' k k', - label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). -Proof. - induction tc. - - intros. simpl in H. discriminate. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + inv H. assert (k = k') by omega. subst. reflexivity. - + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar_some_add: - forall tc l p p' k, - label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_some_add_add; eauto. -Qed. - -Remark label_pos_pvar_add: - forall c tc l p p' k, - label_pos l (p+k) c = label_pos l p tc -> - label_pos l (p'+k) c = label_pos l p' tc. -Proof. - induction c. - - intros. simpl in *. - exploit label_pos_pvar_none; eauto. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + exploit label_pos_pvar_some_add; eauto. - + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar: - forall c tc l p p', - label_pos l p c = label_pos l p tc -> - label_pos l p' c = label_pos l p' tc. -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_add; eauto. -Qed. - -Lemma label_pos_head_app: - forall c bb lbb l tc p, - verified_schedule bb = OK lbb -> - label_pos l p c = label_pos l p tc -> - label_pos l p (bb :: c) = label_pos l p (lbb ++ tc). -Proof. - intros. simpl. destruct lbb as [|tbb lbb]. - - apply verified_schedule_not_empty in H. contradiction. - - simpl. exploit verified_schedule_label; eauto. intros (ISLBL & LBLPOS). - rewrite ISLBL. - destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. - eapply label_pos_pvar in H0. erewrite H0. - erewrite verified_schedule_size; eauto. simpl size_blocks. rewrite Z.add_assoc. - erewrite label_pos_app_none; eauto. -Qed. - -Lemma label_pos_preserved: - forall c tc l, - transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. -Proof. - induction c. - - intros. simpl in *. inv H. reflexivity. - - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. eapply IHc in EQ. - eapply label_pos_head_app; eauto. -Qed. - -Lemma label_pos_preserved_blocks: - forall l f tf, - transf_function f = OK tf -> - label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). -Proof. - intros. monadInv H. monadInv EQ. - destruct (zlt Ptrofs.max_unsigned _); try discriminate. - monadInv EQ0. simpl. eapply label_pos_preserved; eauto. -Qed. - -Lemma transf_exec_control: - forall f tf ex rs m, - transf_function f = OK tf -> - exec_control ge f ex rs m = exec_control tge tf ex rs m. -Proof. - intros. destruct ex; simpl; auto. - assert (ge = Genv.globalenv prog). auto. - assert (tge = Genv.globalenv tprog). auto. - pose symbol_address_preserved. - exploreInst; simpl; auto; try congruence. - - unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. -Qed. - -Lemma eval_offset_preserved: - forall ofs, eval_offset ge ofs = eval_offset tge ofs. -Proof. - intros. unfold eval_offset. destruct ofs; auto. erewrite symbol_address_preserved; eauto. -Qed. - -Lemma transf_exec_load: - forall t rs m rd ra ofs, exec_load ge t rs m rd ra ofs = exec_load tge t rs m rd ra ofs. -Proof. - intros. unfold exec_load. rewrite eval_offset_preserved. reflexivity. -Qed. - -Lemma transf_exec_store: - forall t rs m rs0 ra ofs, exec_store ge t rs m rs0 ra ofs = exec_store tge t rs m rs0 ra ofs. -Proof. - intros. unfold exec_store. rewrite eval_offset_preserved. reflexivity. -Qed. - -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. exploreInst; simpl; auto; try congruence. - 1: unfold exec_arith_instr; exploreInst; simpl; auto; try congruence. - 1-10: apply transf_exec_load. - all: apply transf_exec_store. -Qed. - -Lemma transf_exec_body: - forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. -Proof. - induction bdy; intros. - - simpl. reflexivity. - - simpl. rewrite transf_exec_basic_instr. - destruct (exec_basic_instr _ _ _); auto. -Qed. - -Lemma transf_exec_bblock: - forall f tf bb rs m, - transf_function f = OK tf -> - exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. -Proof. - intros. unfold exec_bblock. rewrite transf_exec_body. destruct (exec_body _ _ _ _); auto. - eapply transf_exec_control; eauto. -Qed. - -Lemma transf_step_simu: - forall tf b lbb ofs c tbb rs m rs' m', - Genv.find_funct_ptr tge b = Some (Internal tf) -> - size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned -> - rs PC = Vptr b ofs -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c) -> - concat_all lbb = OK tbb -> - exec_bblock tge tf tbb rs m = Next rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - induction lbb. - - intros until m'. simpl. intros. discriminate. - - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. - destruct lbb. - + simpl in *. clear IHlbb. inv CONC. eapply plus_one. econstructor; eauto. eapply find_bblock_tail; eauto. - + exploit concat_all_exec_bblock; eauto; try discriminate. - intros (tbb0 & rs0 & m0 & CONC0 & EXEB0 & PCeq' & EXEB1). - eapply plus_left. - econstructor. - 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. - all: eauto. - eapply plus_star. eapply IHlbb; eauto. rewrite PCeq in PCeq'. simpl in PCeq'. all: eauto. - eapply code_tail_next_int; eauto. -Qed. - -Theorem transf_step_correct: - forall s1 t s2, step ge s1 t s2 -> - forall s1' (MS: match_states s1 s1'), - (exists s2', plus step tge s1' t s2' /\ match_states s2 s2'). -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). - assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - - erewrite transf_exec_bblock in H2; eauto. - inv BBEQ. rewrite H3 in H2. - exists (State rs' m'). split; try (constructor; auto). - eapply transf_step_simu; eauto. - - - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. - exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). - exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. - - remember (State (nextblock _ _) _) as s'. exists s'. - split; try constructor; auto. - eapply plus_one. subst s'. - eapply exec_step_builtin. - 3: eapply find_bblock_tail. simpl in TAIL. 3: eauto. - all: eauto. - eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - - - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. - remember (State _ m') as s'. exists s'. split; try constructor; auto. - subst s'. eapply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. -Qed. - -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_plus. - - apply senv_preserved. - - apply transf_initial_states. - - apply transf_final_states. - - apply transf_step_correct. -Qed. - -End PRESERVATION. +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 PostpassScheduling. +Require Import Asmblockgenproof. +Require Import Axioms. + +Local Open Scope error_monad_scope. + +Definition match_prog (p tp: Asmblock.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. + +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 verified_schedule_builtin_idem (ge: Genv.t fundef unit) (fn: function): + forall bb ef args res lbb, + exit bb = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bb = OK lbb -> + lbb = bb :: nil. +Proof. + intros. exploit builtin_body_nil; eauto. intros. + rewrite verified_schedule_single_inst in H0; auto. + - inv H0. auto. + - unfold size. rewrite H. rewrite H1. simpl. auto. +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 {A: Type}: + forall (rs rs':A) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros. congruence. +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). +Proof. + intros. apply functional_extensionality. intros. destruct (preg_eq r x). + - subst r. repeat (rewrite Pregmap.gss; auto). + - repeat (rewrite Pregmap.gso); auto. +Qed. + +Lemma exec_load_pc_var: + forall ge t rs m rd ra ofs rs' m' v, + exec_load ge t rs m rd ra ofs = Next rs' m' -> + exec_load ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge 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_store_pc_var: + forall ge t rs m rd ra ofs rs' m' v, + exec_store ge t rs m rd ra ofs = Next rs' m' -> + exec_store ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); 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 *. 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). + - exploreInst; apply exec_load_pc_var; auto. + - exploreInst; apply exec_store_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 GPR14 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' -> + exec_body ge l (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + induction l. + - intros. simpl. simpl in H. inv H. auto. + - intros. simpl in *. + destruct (exec_basic_instr ge a rs m) eqn:EXEBI; try discriminate. + erewrite exec_basic_instr_pc_var; eauto. +Qed. + +Lemma pc_set_add: + forall rs v r x y, + 0 <= x <= Ptrofs.max_unsigned -> + 0 <= y <= Ptrofs.max_unsigned -> + rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). +Proof. + intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). + - 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. + unfold Ptrofs.add. + cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. + repeat (rewrite Ptrofs.unsigned_repr); auto. + - repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma concat2_straight: + forall a b bb rs m rs'' m'' f ge, + concat2 a b = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists rs' m', + exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f b rs' m' = Next rs'' m''. +Proof. + intros until ge. intros CONC2 EXEB. + exploit concat2_zlt_size; eauto. intros (LTA & LTB). + exploit concat2_noexit; eauto. intros EXA. + exploit concat2_decomp; eauto. intros. inv H. + unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. + rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. + unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. + exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. + unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. + rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. + assert (size bb = size a + size b). + { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. + repeat (rewrite Nat2Z.inj_add). omega. } + clear EXA H0 H1. rewrite H in EXEB. + assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } + rewrite H0. rewrite <- pc_set_add; auto. + exploit AB.size_positive. instantiate (1 := a). intro. omega. + exploit AB.size_positive. instantiate (1 := b). intro. omega. +Qed. + +Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : + forall a bb rs m lbb rs'' m'', + lbb <> nil -> + concat_all (a :: lbb) = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists bb' rs' m', + concat_all lbb = OK bb' + /\ exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. +Proof. + intros until m''. intros Hnonil CONC EXEB. + simpl in CONC. + destruct lbb as [|b lbb]; try contradiction. clear Hnonil. + monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). + exists x. repeat econstructor. all: eauto. +Qed. + +Lemma ptrofs_add_repr : + forall a b, + Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). +Proof. + intros a b. + rewrite Ptrofs.add_unsigned. repeat (rewrite Ptrofs.unsigned_repr_eq). + rewrite <- Zplus_mod. auto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +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. + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_match TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSL). + +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 function_ptr_translated; eauto. + intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. +Qed. + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s1 s2, s1 = s2 -> match_states s1 s2. + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSL). + +Lemma prog_main_address_preserved: + (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = + (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). +Proof. + unfold Genv.symbol_address. rewrite symbols_preserved. + rewrite prog_main_preserved. auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + econstructor; split. + - eapply initial_state_intro. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. econstructor; eauto. +Qed. + +Lemma tail_find_bblock: + forall lbb pos bb, + find_bblock pos lbb = Some bb -> + exists c, code_tail pos lbb (bb::c). +Proof. + induction lbb. + - intros. simpl in H. inv H. + - intros. simpl in H. + destruct (zlt pos 0); try (inv H; fail). + 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. + omega. +Qed. + +Lemma code_tail_head_app: + forall l pos c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + size_blocks l) (l++c1) c2. +Proof. + induction l. + - intros. simpl. rewrite Z.add_0_r. auto. + - intros. apply IHl in H. simpl. rewrite (Z.add_comm (size a)). rewrite Z.add_assoc. apply code_tail_S. assumption. +Qed. + +Lemma transf_blocks_verified: + forall c tc pos bb c', + transf_blocks c = OK tc -> + code_tail pos c (bb::c') -> + exists lbb, + verified_schedule bb = OK lbb + /\ exists tc', code_tail pos tc (lbb ++ tc'). +Proof. + induction c; intros. + - simpl in H. inv H. inv H0. + - inv H0. + + monadInv H. exists x0. + split; simpl; auto. eexists; eauto. econstructor; eauto. + + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. + exploit IHc; eauto. + intros (lbb & TRANS & tc' & TAIL). +(* monadInv TRANS. *) + repeat eexists; eauto. + erewrite verified_schedule_size; eauto. + apply code_tail_head_app. + eauto. +Qed. + +Lemma transf_find_bblock: + forall ofs f bb tf, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + transf_function f = OK tf -> + exists lbb, + verified_schedule bb = OK lbb + /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). +Proof. + intros. + monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. + monadInv EQ. apply tail_find_bblock in H. destruct H as (c & TAIL). + eapply transf_blocks_verified; eauto. +Qed. + +Lemma symbol_address_preserved: + forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. +Proof. + intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. +Qed. + +Lemma head_tail {A: Type}: + forall (l: list A) hd, hd::l = hd :: (tail (hd::l)). +Proof. + intros. simpl. auto. +Qed. + +Lemma verified_schedule_not_empty: + forall bb lbb, + verified_schedule bb = OK lbb -> lbb <> nil. +Proof. + intros. apply verified_schedule_size in H. + pose (size_positive bb). assert (size_blocks lbb > 0) by omega. clear H g. + destruct lbb; simpl in *; discriminate. +Qed. + +Lemma header_nil_label_pos_none: + forall lbb l p, + Forall (fun b => header b = nil) lbb -> label_pos l p lbb = None. +Proof. + induction lbb. + - intros. simpl. auto. + - intros. inv H. simpl. unfold is_label. rewrite H2. destruct (in_dec l nil). { inv i. } + auto. +Qed. + +Lemma verified_schedule_label: + forall bb tbb lbb l, + verified_schedule bb = OK (tbb :: lbb) -> + is_label l bb = is_label l tbb + /\ label_pos l 0 lbb = None. +Proof. + intros. exploit verified_schedule_header; eauto. + intros (HdrEq & HdrNil). + split. + - unfold is_label. rewrite HdrEq. reflexivity. + - apply header_nil_label_pos_none. assumption. +Qed. + +Lemma label_pos_app_none: + forall c c' l p p', + label_pos l p c = None -> + label_pos l (p' + size_blocks c) c' = label_pos l p' (c ++ c'). +Proof. + induction c. + - intros. simpl in *. rewrite Z.add_0_r. reflexivity. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLABEL. + + discriminate. + + eapply IHc in H. rewrite Z.add_assoc. eauto. +Qed. + +Remark label_pos_pvar_none_add: + forall tc l p p' k, + label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. +Proof. + induction tc. + - intros. simpl. auto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + discriminate. + + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_none: + forall tc l p p', + label_pos l p tc = None -> label_pos l p' tc = None. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_none_add; eauto. +Qed. + +Remark label_pos_pvar_some_add_add: + forall tc l p p' k k', + label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). +Proof. + induction tc. + - intros. simpl in H. discriminate. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + inv H. assert (k = k') by omega. subst. reflexivity. + + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_some_add: + forall tc l p p' k, + label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_some_add_add; eauto. +Qed. + +Remark label_pos_pvar_add: + forall c tc l p p' k, + label_pos l (p+k) c = label_pos l p tc -> + label_pos l (p'+k) c = label_pos l p' tc. +Proof. + induction c. + - intros. simpl in *. + exploit label_pos_pvar_none; eauto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + exploit label_pos_pvar_some_add; eauto. + + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar: + forall c tc l p p', + label_pos l p c = label_pos l p tc -> + label_pos l p' c = label_pos l p' tc. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_add; eauto. +Qed. + +Lemma label_pos_head_app: + forall c bb lbb l tc p, + verified_schedule bb = OK lbb -> + label_pos l p c = label_pos l p tc -> + label_pos l p (bb :: c) = label_pos l p (lbb ++ tc). +Proof. + intros. simpl. destruct lbb as [|tbb lbb]. + - apply verified_schedule_not_empty in H. contradiction. + - simpl. exploit verified_schedule_label; eauto. intros (ISLBL & LBLPOS). + rewrite ISLBL. + destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. + eapply label_pos_pvar in H0. erewrite H0. + erewrite verified_schedule_size; eauto. simpl size_blocks. rewrite Z.add_assoc. + erewrite label_pos_app_none; eauto. +Qed. + +Lemma label_pos_preserved: + forall c tc l, + transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. +Proof. + induction c. + - intros. simpl in *. inv H. reflexivity. + - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. eapply IHc in EQ. + eapply label_pos_head_app; eauto. +Qed. + +Lemma label_pos_preserved_blocks: + forall l f tf, + transf_function f = OK tf -> + label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). +Proof. + intros. monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned _); try discriminate. + monadInv EQ0. simpl. eapply label_pos_preserved; eauto. +Qed. + +Lemma transf_exec_control: + forall f tf ex rs m, + transf_function f = OK tf -> + exec_control ge f ex rs m = exec_control tge tf ex rs m. +Proof. + intros. destruct ex; simpl; auto. + assert (ge = Genv.globalenv prog). auto. + assert (tge = Genv.globalenv tprog). auto. + pose symbol_address_preserved. + exploreInst; simpl; auto; try congruence. + - unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. +Qed. + +Lemma eval_offset_preserved: + forall ofs, eval_offset ge ofs = eval_offset tge ofs. +Proof. + intros. unfold eval_offset. destruct ofs; auto. erewrite symbol_address_preserved; eauto. +Qed. + +Lemma transf_exec_load: + forall t rs m rd ra ofs, exec_load ge t rs m rd ra ofs = exec_load tge t rs m rd ra ofs. +Proof. + intros. unfold exec_load. rewrite eval_offset_preserved. reflexivity. +Qed. + +Lemma transf_exec_store: + forall t rs m rs0 ra ofs, exec_store ge t rs m rs0 ra ofs = exec_store tge t rs m rs0 ra ofs. +Proof. + intros. unfold exec_store. rewrite eval_offset_preserved. reflexivity. +Qed. + +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. exploreInst; simpl; auto; try congruence. + 1: unfold exec_arith_instr; exploreInst; simpl; auto; try congruence. + 1-10: apply transf_exec_load. + all: apply transf_exec_store. +Qed. + +Lemma transf_exec_body: + forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. +Proof. + induction bdy; intros. + - simpl. reflexivity. + - simpl. rewrite transf_exec_basic_instr. + destruct (exec_basic_instr _ _ _); auto. +Qed. + +Lemma transf_exec_bblock: + forall f tf bb rs m, + transf_function f = OK tf -> + exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. +Proof. + intros. unfold exec_bblock. rewrite transf_exec_body. destruct (exec_body _ _ _ _); auto. + eapply transf_exec_control; eauto. +Qed. + +Lemma transf_step_simu: + forall tf b lbb ofs c tbb rs m rs' m', + Genv.find_funct_ptr tge b = Some (Internal tf) -> + size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned -> + rs PC = Vptr b ofs -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c) -> + concat_all lbb = OK tbb -> + exec_bblock tge tf tbb rs m = Next rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + induction lbb. + - intros until m'. simpl. intros. discriminate. + - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. + destruct lbb. + + simpl in *. clear IHlbb. inv CONC. eapply plus_one. econstructor; eauto. eapply find_bblock_tail; eauto. + + exploit concat_all_exec_bblock; eauto; try discriminate. + intros (tbb0 & rs0 & m0 & CONC0 & EXEB0 & PCeq' & EXEB1). + eapply plus_left. + econstructor. + 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. + all: eauto. + eapply plus_star. eapply IHlbb; eauto. rewrite PCeq in PCeq'. simpl in PCeq'. all: eauto. + eapply code_tail_next_int; eauto. +Qed. + +Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', plus step tge s1' t s2' /\ match_states s2 s2'). +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). + assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + + erewrite transf_exec_bblock in H2; eauto. + inv BBEQ. rewrite H3 in H2. + exists (State rs' m'). split; try (constructor; auto). + eapply transf_step_simu; eauto. + + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). + exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. + + remember (State (nextblock _ _) _) as s'. exists s'. + split; try constructor; auto. + eapply plus_one. subst s'. + eapply exec_step_builtin. + 3: eapply find_bblock_tail. simpl in TAIL. 3: eauto. + all: eauto. + eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + remember (State _ m') as s'. exists s'. split; try constructor; auto. + subst s'. eapply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. +Qed. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_plus. + - apply senv_preserved. + - apply transf_initial_states. + - apply transf_final_states. + - apply transf_step_correct. +Qed. + +End PRESERVATION. -- cgit From 12f0b90362f079cb1386883fe2d87a7d6955faa3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 12:05:30 +0100 Subject: Removing unused cases Asmblockgen --- mppa_k1c/Asmblockgen.v | 3 --- 1 file changed, 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 6503e5b3..95bb5a36 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -611,11 +611,8 @@ Definition transl_op | Osubfs , _ => Error (msg "Asmblockgen.transl_op: Osubfs") | Omulfs , _ => Error (msg "Asmblockgen.transl_op: Omulfs") | Odivfs , _ => Error (msg "Asmblockgen.transl_op: Odivfs") - | Ofloatoflongu , _ => Error (msg "Asmblockgen.transl_op: Ofloatoflongu") | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") - | Osingleoffloat , _ => Error (msg "Asmblockgen.transl_op: Osingleoffloat") - | Ofloatofsingle , _ => Error (msg "Asmblockgen.transl_op: Ofloatofsingle") | Ointoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointoffloat") | Ointuoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointuoffloat") | Ofloatofint , _ => Error (msg "Asmblockgen.transl_op: Ofloatofint") -- cgit From b31983dea996d3149cb188efe4f4a32690ed49ad Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 12:06:53 +0100 Subject: FIX the order of operands of float sub was inverted --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index bbb608de..baeb493a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -382,9 +382,9 @@ module Target (*: TARGET*) = | Pfaddw (rd, rs1, rs2) -> fprintf oc " faddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfsbfd (rd, rs1, rs2) -> - fprintf oc " fsbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " fsbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pfsbfw (rd, rs1, rs2) -> - fprintf oc " fsbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + fprintf oc " fsbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pfmuld (rd, rs1, rs2) -> fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfmulw (rd, rs1, rs2) -> -- cgit From b09dea1ebfa5358e4d866e03e5a024c968c6a0b8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 14:33:14 +0100 Subject: Fixed some additional operands inversions --- mppa_k1c/TargetPrinter.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index baeb493a..c1339af5 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -295,13 +295,13 @@ module Target (*: TARGET*) = | Pfabsw(rd, rs) -> fprintf oc " fabsw %a = %a\n" ireg rd ireg rs | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n" ireg rs ireg rd + fprintf oc " fnegd %a = %a\n" ireg rd ireg rs | Pfnegw(rd, rs) -> - fprintf oc " fnegw %a = %a\n" ireg rs ireg rd + fprintf oc " fnegw %a = %a\n" ireg rd ireg rs | Pfnarrowdw(rd, rs) -> - fprintf oc " fnarrowdw %a = %a\n" ireg rs ireg rd + fprintf oc " fnarrowdw %a = %a\n" ireg rd ireg rs | Pfwidenlwd(rd, rs) -> - fprintf oc " fwidenlwd %a = %a\n" ireg rs ireg rd + fprintf oc " fwidenlwd %a = %a\n" ireg rd ireg rs | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfloatudrnsz(rd, rs) -> -- cgit From f50d5b2e7d689a0033943fca270d322b33c1a781 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Feb 2019 18:02:33 +0100 Subject: Float conversion fixes + some more conversions --- mppa_k1c/Asm.v | 16 ++++++++++++++-- mppa_k1c/Asmblock.v | 16 ++++++++++++++-- mppa_k1c/Asmblockdeps.v | 6 ++++++ mppa_k1c/Asmblockgen.v | 24 ++++++++++++++++++++++++ mppa_k1c/PostpassScheduling.v | 1 - mppa_k1c/PostpassSchedulingOracle.ml | 18 +++++++++++++++--- mppa_k1c/SelectLong.v | 17 +++++++++++++---- mppa_k1c/SelectLong.vp | 17 +++++++++++++---- mppa_k1c/SelectLongproof.v | 16 ++++++++-------- mppa_k1c/TargetPrinter.ml | 10 +++++++--- 10 files changed, 114 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 7c735bf1..d930b168 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -103,11 +103,17 @@ Inductive instruction : Type := | 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 *) + | 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) *) + | Pfloatudrnsz_i32 (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (32 bits) *) | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfloatdrnsz_i32 (rd rs: ireg) (**r Floating Point Conversion from integer (32 bits) *) | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (64 bits) *) + | 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 *) @@ -216,11 +222,17 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pfnegw rd rs => Pfnegw rd rs | PArithRR Asmblock.Pfnarrowdw rd rs => Pfnarrowdw rd rs | PArithRR Asmblock.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmblock.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs | PArithRR Asmblock.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs | PArithRR Asmblock.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmblock.Pfloatudrnsz_i32 rd rs => Pfloatudrnsz_i32 rd rs + | PArithRR Asmblock.Pfloatdrnsz_i32 rd rs => Pfloatdrnsz_i32 rd rs | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs | PArithRR Asmblock.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmblock.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmblock.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmblock.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs (* RI32 *) | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cade1ba8..a5c7f495 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -287,11 +287,17 @@ Inductive arith_name_rr : Type := | Pfnegw (**r float negate 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) *) - | Pfloatudrnsz (**r Floating Point Conversion from unsigned integer (ulong -> float) *) + | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) + | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) + | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) + | Pfloatudrnsz_i32 (**r Floating Point Conversion from integer (unsigned int -> float) *) | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) + | Pfloatdrnsz_i32 (**r Floating Point Conversion from integer (int -> float) *) | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) + | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) + | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) + | Pfixedudrzz_i32 (**r Integer conversion from floating point (float -> unsigned int) *) . Inductive arith_name_ri32 : Type := @@ -936,10 +942,16 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pfnarrowdw => rs#d <- (Val.singleoffloat rs#s) | Pfwidenlwd => rs#d <- (Val.floatofsingle rs#s) | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) + | Pfloatuwrnsz => rs#d <- (match Val.singleofintu rs#s with Some f => f | _ => Vundef end) | Pfloatudrnsz => rs#d <- (match Val.floatoflongu rs#s with Some f => f | _ => Vundef end) + | Pfloatudrnsz_i32 => rs#d <- (match Val.floatofintu rs#s with Some f => f | _ => Vundef end) | Pfloatdrnsz => rs#d <- (match Val.floatoflong rs#s with Some f => f | _ => Vundef end) + | Pfloatdrnsz_i32 => rs#d <- (match Val.floatofint rs#s with Some f => f | _ => Vundef end) | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) | Pfixeddrzz => rs#d <- (match Val.longoffloat rs#s with Some i => i | _ => Vundef end) + | Pfixeddrzz_i32 => rs#d <- (match Val.intoffloat rs#s with Some i => i | _ => Vundef end) + | Pfixedudrzz => rs#d <- (match Val.longuoffloat rs#s with Some i => i | _ => Vundef end) + | Pfixedudrzz_i32 => rs#d <- (match Val.intuoffloat rs#s with Some i => i | _ => Vundef end) end | PArithRI32 n d i => diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4d1a0d38..ee087d44 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -117,10 +117,16 @@ Definition arith_eval (ao: arith_op) (l: list value) := | Pfnarrowdw => Some (Val (Val.singleoffloat v)) | Pfwidenlwd => Some (Val (Val.floatofsingle v)) | Pfloatwrnsz => Some (Val (match Val.singleofint v with Some f => f | _ => Vundef end)) + | Pfloatuwrnsz => Some (Val (match Val.singleofintu v with Some f => f | _ => Vundef end)) | Pfloatudrnsz => Some (Val (match Val.floatoflongu v with Some f => f | _ => Vundef end)) | Pfloatdrnsz => Some (Val (match Val.floatoflong v with Some f => f | _ => Vundef end)) + | Pfloatudrnsz_i32 => Some (Val (match Val.floatofintu v with Some f => f | _ => Vundef end)) + | Pfloatdrnsz_i32 => Some (Val (match Val.floatofint v with Some f => f | _ => Vundef end)) | Pfixedwrzz => Some (Val (match Val.intofsingle v with Some i => i | _ => Vundef end)) | Pfixeddrzz => Some (Val (match Val.longoffloat v with Some i => i | _ => Vundef end)) + | Pfixedudrzz => Some (Val (match Val.longuoffloat v with Some i => i | _ => Vundef end)) + | Pfixeddrzz_i32 => Some (Val (match Val.intoffloat v with Some i => i | _ => Vundef end)) + | Pfixedudrzz_i32 => Some (Val (match Val.intuoffloat v with Some i => i | _ => Vundef end)) end | OArithRI32 n i, [] => diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 95bb5a36..8dfa2cee 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -579,18 +579,42 @@ Definition transl_op | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatwrnsz rd rs ::i k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatuwrnsz rd rs ::i k) | Ofloatoflong, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatdrnsz rd rs ::i k) | Ofloatoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatudrnsz rd rs ::i k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatdrnsz_i32 rd rs ::i k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatudrnsz_i32 rd rs ::i k) + (* | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatwrnsz rd rs ::i k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatuwrnsz rd rs ::i k) *) (* FIXME - Ofloatofint and Ofloatofintu are currently incorrect *) | Ointofsingle, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedwrzz rd rs ::i k) | Olongoffloat, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixeddrzz rd rs ::i k) + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeddrzz_i32 rd rs ::i k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedudrzz rd rs ::i k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedudrzz_i32 rd rs ::i k) | Ofloatofsingle, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 6bf97279..fa0ebfe6 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -13,7 +13,6 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. Require Import Asmblockdeps Asmblockgenproof0. -Require Import ImpDep. Local Open Scope error_monad_scope. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 54a27966..d9a60fb4 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -40,10 +40,16 @@ let arith_rr_str = function | Pfnarrowdw -> "Pfnarrowdw" | Pfwidenlwd -> "Pfwidenlwd" | Pfloatwrnsz -> "Pfloatwrnsz" + | Pfloatuwrnsz -> "Pfloatuwrnsz" + | Pfloatudrnsz_i32 -> "Pfloatudrnsz_i32" | Pfloatudrnsz -> "Pfloatudrnsz" | Pfloatdrnsz -> "Pfloatdrnsz" + | Pfloatdrnsz_i32 -> "Pfloatdrnsz_i32" | Pfixedwrzz -> "Pfixedwrzz" | Pfixeddrzz -> "Pfixeddrzz" + | Pfixedudrzz -> "Pfixedudrzz" + | Pfixeddrzz_i32 -> "Pfixeddrzz_i32" + | Pfixedudrzz_i32 -> "Pfixedudrzz_i32" let arith_rrr_str = function | Pcompw it -> "Pcompw" @@ -365,7 +371,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fnarrowdw | Fwidenlwd | Floatwz | Floatdz | Floatudz | Fixedwz | Fixeddz + | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeddz | Fixedudz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -395,10 +401,16 @@ let ab_inst_to_real = function | "Pfnarrowdw" -> Fnarrowdw | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz + | "Pfloatuwrnsz" -> Floatuwz | "Pfloatdrnsz" -> Floatdz + | "Pfloatdrnsz_i32" -> Floatdz | "Pfloatudrnsz" -> Floatudz + | "Pfloatudrnsz_i32" -> Floatudz | "Pfixedwrzz" -> Fixedwz | "Pfixeddrzz" -> Fixeddz + | "Pfixedudrzz" -> Fixedudz + | "Pfixeddrzz_i32" -> Fixeddz + | "Pfixedudrzz_i32" -> Fixedudz | "Plb" -> Lbs | "Plbu" -> Lbz @@ -469,7 +481,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Fixedwz | Floatwz | Fixeddz | Floatdz | Floatudz -> mau + | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -490,7 +502,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 - | Floatwz | Fixedwz | Floatdz | Floatudz | Fixeddz -> 4 + | Floatwz | Floatuwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd diff --git a/mppa_k1c/SelectLong.v b/mppa_k1c/SelectLong.v index f2aa6be2..ea42b9c3 100644 --- a/mppa_k1c/SelectLong.v +++ b/mppa_k1c/SelectLong.v @@ -755,20 +755,29 @@ Definition floatoflongu (e: expr) := if Archi.splitlong then SplitLong.floatoflongu e else Eop Ofloatoflongu (e:::Enil). -Definition longofsingle (e: expr) := +(* FIXME - normally we can have it natively, but in practice it requires proving that we can do Fwidenlwd + fixedd.rz.. To do later *) +Definition longofsingle (e: expr) := SplitLong.longofsingle e. +(* if Archi.splitlong then SplitLong.longofsingle e else Eop Olongofsingle (e:::Enil). +*) -Definition longuofsingle (e: expr) := +Definition longuofsingle (e: expr) := SplitLong.longuofsingle e. +(* if Archi.splitlong then SplitLong.longuofsingle e else Eop Olonguofsingle (e:::Enil). +*) -Definition singleoflong (e: expr) := +Definition singleoflong (e: expr) := SplitLong.singleoflong e. +(* if Archi.splitlong then SplitLong.singleoflong e else Eop Osingleoflong (e:::Enil). +*) -Definition singleoflongu (e: expr) := +Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. +(* if Archi.splitlong then SplitLong.singleoflongu e else Eop Osingleoflongu (e:::Enil). +*) End SELECT. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 26735c99..a3aefb15 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -341,20 +341,29 @@ Definition floatoflongu (e: expr) := if Archi.splitlong then SplitLong.floatoflongu e else Eop Ofloatoflongu (e:::Enil). -Definition longofsingle (e: expr) := +(* FIXME - normally we can have it natively, but in practice it requires proving that we can do Fwidenlwd + fixedd.rz.. To do later *) +Definition longofsingle (e: expr) := SplitLong.longofsingle e. +(* if Archi.splitlong then SplitLong.longofsingle e else Eop Olongofsingle (e:::Enil). +*) -Definition longuofsingle (e: expr) := +Definition longuofsingle (e: expr) := SplitLong.longuofsingle e. +(* if Archi.splitlong then SplitLong.longuofsingle e else Eop Olonguofsingle (e:::Enil). +*) -Definition singleoflong (e: expr) := +Definition singleoflong (e: expr) := SplitLong.singleoflong e. +(* if Archi.splitlong then SplitLong.singleoflong e else Eop Osingleoflong (e:::Enil). +*) -Definition singleoflongu (e: expr) := +Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. +(* if Archi.splitlong then SplitLong.singleoflongu e else Eop Osingleoflongu (e:::Enil). +*) End SELECT. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index d12fb9ae..44846a6f 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -582,30 +582,30 @@ Qed. Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. Proof. - unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL. + unfold longofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) eapply SplitLongproof.eval_longofsingle; eauto. - TrivialExists. +(* TrivialExists. *) Qed. Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. Proof. - unfold longuofsingle; red; intros. destruct Archi.splitlong eqn:SL. + unfold longuofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) eapply SplitLongproof.eval_longuofsingle; eauto. - TrivialExists. +(* TrivialExists. *) Qed. Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. Proof. - unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL. + unfold singleoflong; red; intros. (* destruct Archi.splitlong eqn:SL. *) eapply SplitLongproof.eval_singleoflong; eauto. - TrivialExists. +(* TrivialExists. *) Qed. Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. Proof. - unfold singleoflongu; red; intros. destruct Archi.splitlong eqn:SL. + unfold singleoflongu; red; intros. (* destruct Archi.splitlong eqn:SL. *) eapply SplitLongproof.eval_singleoflongu; eauto. - TrivialExists. +(* TrivialExists. *) Qed. End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index c1339af5..8d053cde 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -302,16 +302,20 @@ module Target (*: TARGET*) = fprintf oc " fnarrowdw %a = %a\n" ireg rd ireg rs | Pfwidenlwd(rd, rs) -> fprintf oc " fwidenlwd %a = %a\n" ireg rd ireg rs + | Pfloatuwrnsz(rd, rs) -> + fprintf oc " floatuw.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatudrnsz(rd, rs) -> + | Pfloatudrnsz(rd, rs) | Pfloatudrnsz_i32(rd, rs) -> fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatdrnsz(rd, rs) -> + | Pfloatdrnsz(rd, rs) | Pfloatdrnsz_i32(rd, rs) -> fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfixedwrzz(rd, rs) -> fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs - | Pfixeddrzz(rd, rs) -> + | Pfixeddrzz(rd, rs) | Pfixeddrzz_i32(rd, rs) -> fprintf oc " fixedd.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixedudrzz(rd, rs) | Pfixedudrzz_i32(rd, rs) -> + fprintf oc " fixedud.rz %a = %a, 0\n" ireg rd ireg rs (* Arith RI32 instructions *) | Pmake (rd, imm) -> -- cgit From df32503f46a62b18f92363ac7f81ec0d5b36c64a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Mar 2019 14:44:09 +0100 Subject: Ointuofsingle done --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 2 ++ mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 40 ++++++++++-------------------------- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++--- mppa_k1c/TargetPrinter.ml | 2 ++ 6 files changed, 23 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d930b168..dcce98d0 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -110,6 +110,7 @@ Inductive instruction : Type := | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) | Pfloatdrnsz_i32 (rd rs: ireg) (**r Floating Point Conversion from integer (32 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) *) @@ -229,6 +230,7 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmblock.Pfloatudrnsz_i32 rd rs => Pfloatudrnsz_i32 rd rs | PArithRR Asmblock.Pfloatdrnsz_i32 rd rs => Pfloatdrnsz_i32 rd rs | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmblock.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs | PArithRR Asmblock.Pfixeddrzz rd rs => Pfixeddrzz rd rs | PArithRR Asmblock.Pfixedudrzz rd rs => Pfixedudrzz rd rs | PArithRR Asmblock.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index a5c7f495..54bf247f 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -294,6 +294,7 @@ Inductive arith_name_rr : Type := | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) | Pfloatdrnsz_i32 (**r Floating Point Conversion from integer (int -> float) *) | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) + | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) @@ -948,6 +949,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pfloatdrnsz => rs#d <- (match Val.floatoflong rs#s with Some f => f | _ => Vundef end) | Pfloatdrnsz_i32 => rs#d <- (match Val.floatofint rs#s with Some f => f | _ => Vundef end) | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) + | Pfixeduwrzz => rs#d <- (match Val.intuofsingle rs#s with Some i => i | _ => Vundef end) | Pfixeddrzz => rs#d <- (match Val.longoffloat rs#s with Some i => i | _ => Vundef end) | Pfixeddrzz_i32 => rs#d <- (match Val.intoffloat rs#s with Some i => i | _ => Vundef end) | Pfixedudrzz => rs#d <- (match Val.longuoffloat rs#s with Some i => i | _ => Vundef end) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index ee087d44..67ca94e2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -123,6 +123,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | Pfloatudrnsz_i32 => Some (Val (match Val.floatofintu v with Some f => f | _ => Vundef end)) | Pfloatdrnsz_i32 => Some (Val (match Val.floatofint v with Some f => f | _ => Vundef end)) | Pfixedwrzz => Some (Val (match Val.intofsingle v with Some i => i | _ => Vundef end)) + | Pfixeduwrzz => Some (Val (match Val.intuofsingle v with Some i => i | _ => Vundef end)) | Pfixeddrzz => Some (Val (match Val.longoffloat v with Some i => i | _ => Vundef end)) | Pfixedudrzz => Some (Val (match Val.longuoffloat v with Some i => i | _ => Vundef end)) | Pfixeddrzz_i32 => Some (Val (match Val.intoffloat v with Some i => i | _ => Vundef end)) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 8dfa2cee..56d061c2 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -594,27 +594,24 @@ Definition transl_op | Ofloatofintu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatudrnsz_i32 rd rs ::i k) - (* | Ofloatofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatwrnsz rd rs ::i k) - | Ofloatofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatuwrnsz rd rs ::i k) *) (* FIXME - Ofloatofint and Ofloatofintu are currently incorrect *) | Ointofsingle, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedwrzz rd rs ::i k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeduwrzz rd rs ::i k) | Olongoffloat, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixeddrzz rd rs ::i k) | Ointoffloat, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixeddrzz_i32 rd rs ::i k) - | Olonguoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixedudrzz rd rs ::i k) | Ointuoffloat, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedudrzz_i32 rd rs ::i k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedudrzz rd rs ::i k) | Ofloatofsingle, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; @@ -624,31 +621,16 @@ Definition transl_op OK (Pfnarrowdw rd rs ::i k) - | Oabsf , _ => Error (msg "Asmblockgen.transl_op: Oabsf") - | Oaddf , _ => Error (msg "Asmblockgen.transl_op: Oaddf") - | Osubf , _ => Error (msg "Asmblockgen.transl_op: Osubf") - | Omulf , _ => Error (msg "Asmblockgen.transl_op: Omulf") | Odivf , _ => Error (msg "Asmblockgen.transl_op: Odivf") - | Onegfs , _ => Error (msg "Asmblockgen.transl_op: Onegfs") - | Oabsfs , _ => Error (msg "Asmblockgen.transl_op: Oabsfs") - | Oaddfs , _ => Error (msg "Asmblockgen.transl_op: Oaddfs") - | Osubfs , _ => Error (msg "Asmblockgen.transl_op: Osubfs") - | Omulfs , _ => Error (msg "Asmblockgen.transl_op: Omulfs") - | Odivfs , _ => Error (msg "Asmblockgen.transl_op: Odivfs") - | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") - | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") - | Ointoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointoffloat") - | Ointuoffloat , _ => Error (msg "Asmblockgen.transl_op: Ointuoffloat") - | Ofloatofint , _ => Error (msg "Asmblockgen.transl_op: Ofloatofint") - | Ofloatofintu , _ => Error (msg "Asmblockgen.transl_op: Ofloatofintu") - | Ointuofsingle , _ => Error (msg "Asmblockgen.transl_op: Ointuofsingle") - | Osingleofintu , _ => Error (msg "Asmblockgen.transl_op: Osingleofintu") - | Olonguoffloat , _ => Error (msg "Asmblockgen.transl_op: Olonguoffloat") - + (* We use the Splitlong instead for these four conversions *) + | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") + | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") + + | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index d9a60fb4..c3473b9f 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -46,6 +46,7 @@ let arith_rr_str = function | Pfloatdrnsz -> "Pfloatdrnsz" | Pfloatdrnsz_i32 -> "Pfloatdrnsz_i32" | Pfixedwrzz -> "Pfixedwrzz" + | Pfixeduwrzz -> "Pfixeduwrzz" | Pfixeddrzz -> "Pfixeddrzz" | Pfixedudrzz -> "Pfixedudrzz" | Pfixeddrzz_i32 -> "Pfixeddrzz_i32" @@ -371,7 +372,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeddz | Fixedudz + | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -407,6 +408,7 @@ let ab_inst_to_real = function | "Pfloatudrnsz" -> Floatudz | "Pfloatudrnsz_i32" -> Floatudz | "Pfixedwrzz" -> Fixedwz + | "Pfixeduwrzz" -> Fixeduwz | "Pfixeddrzz" -> Fixeddz | "Pfixedudrzz" -> Fixedudz | "Pfixeddrzz_i32" -> Fixeddz @@ -481,7 +483,7 @@ let rec_to_usage r = | Nop -> alu_nop | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau + | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x @@ -502,7 +504,7 @@ let real_inst_to_latency = function | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd -> 1 - | Floatwz | Floatuwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 + | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8d053cde..acb128de 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -312,6 +312,8 @@ module Target (*: TARGET*) = fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfixedwrzz(rd, rs) -> fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixeduwrzz(rd, rs) -> + fprintf oc " fixeduw.rz %a = %a, 0\n" ireg rd ireg rs | Pfixeddrzz(rd, rs) | Pfixeddrzz_i32(rd, rs) -> fprintf oc " fixedd.rz %a = %a, 0\n" ireg rd ireg rs | Pfixedudrzz(rd, rs) | Pfixedudrzz_i32(rd, rs) -> -- cgit From d8fafb0add258e47287a2d57454194db8f1dd635 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Mar 2019 16:44:07 +0100 Subject: Implemented float comparisons (no branching yet, and no negation) --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 49 ++++++++++++++++++++++++++++++++++++ mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/Asmblockgen.v | 48 +++++++++++++++-------------------- mppa_k1c/Asmblockgenproof.v | 1 + mppa_k1c/Asmblockgenproof1.v | 32 +++++++++++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 12 ++++++++- mppa_k1c/TargetPrinter.ml | 15 +++++++++++ 8 files changed, 132 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index dcce98d0..49f2d23c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -131,6 +131,7 @@ Inductive instruction : Type := (** 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 *) | Paddw (rd rs1 rs2: ireg) (**r add word *) | Psubw (rd rs1 rs2: ireg) (**r sub word *) @@ -251,6 +252,7 @@ Definition basic_to_instruction (b: basic) := (* RRR *) | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmblock.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 | PArithRRR Asmblock.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 54bf247f..274d90a1 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -126,6 +126,17 @@ Inductive itest: Type := | ITnone (**r Not Any Bits Set in Mask *) . +Inductive ftest: Type := + | FTone (**r Ordered and Not Equal *) + | FTueq (**r Unordered or Equal *) + | FToeq (**r Ordered and Equal *) + | FTune (**r Unordered or Not Equal *) + | FTolt (**r Ordered and Less Than *) + | FTuge (**r Unordered or Greater Than or Equal *) + | FToge (**r Ordered and Greater Than or Equal *) + | FTult (**r Unordered or Less Than *) + . + (** Offsets for load and store instructions. An offset is either an immediate integer or the low part of a symbol. *) @@ -320,6 +331,7 @@ Inductive arith_name_rf64 : Type := Inductive arith_name_rrr : Type := | Pcompw (it: itest) (**r comparison word *) | Pcompl (it: itest) (**r comparison long *) + | Pfcompw (it: ftest) (**r comparison float32 *) | Paddw (**r add word *) | Psubw (**r sub word *) @@ -816,6 +828,31 @@ Definition itest_for_cmp (c: comparison) (s: signedness) := | Cgt, Unsigned => ITgtu end. +Inductive oporder_ftest := + | Normal (ft: ftest) + | Reversed (ft: ftest) +. + +Definition ftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FToeq + | Cne => Normal FTune + | Clt => Normal FTolt + | Cle => Reversed FToge + | Cgt => Reversed FTolt + | Cge => Normal FToge + end. + +Definition notftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FTune + | Cne => Normal FToeq + | Clt => Normal FTuge + | Cle => Reversed FTult + | Cgt => Reversed FTuge + | Cge => Normal FTult + end. + (* CoMPare Signed Words to Zero *) Definition btest_for_cmpswz (c: comparison) := match c with @@ -910,6 +947,17 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := end . +Definition compare_single (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpfs Ceq v1 v2 + | FTune => Val.cmpfs Cne v1 v2 + | FTolt => Val.cmpfs Clt v1 v2 + | FTuge => Val.notbool (Val.cmpfs Clt v1 v2) + | FToge => Val.cmpfs Cge v1 v2 + | FTult => Val.notbool (Val.cmpfs Cge v1 v2) + end. + (** Execution of arith instructions TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... @@ -980,6 +1028,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset match n with | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) + | Pfcompw c => rs#d <- (compare_single c rs#s1 rs#s2) | Paddw => rs#d <- (Val.add rs#s1 rs#s2) | Psubw => rs#d <- (Val.sub rs#s1 rs#s2) | Pmulw => rs#d <- (Val.mul rs#s1 rs#s2) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 67ca94e2..69d3d0cc 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -159,6 +159,8 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRR n, [Val v1; Val v2] => match n with + | Pfcompw c => Some (Val (compare_single c v1 v2)) + | Paddw => Some (Val (Val.add v1 v2)) | Psubw => Some (Val (Val.sub v1 v2)) | Pmulw => Some (Val (Val.mul v1 v2)) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 56d061c2..fb6ba16e 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -282,6 +282,18 @@ Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. +Definition transl_cond_float32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompw ft rd r1 r2 ::i k + | Reversed ft => Pfcompw ft rd r2 r1 ::i k + end. + +Definition transl_cond_notfloat32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompw ft rd r1 r2 ::i k + | Reversed ft => Pfcompw ft rd r2 r1 ::i k + end. + Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -309,10 +321,14 @@ Definition transl_cond_op | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (transl_condimm_int64u c rd r1 n k) + | Ccompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_float32 c rd r1 r2 k) +(* | Cnotcompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_notfloat32 c rd r1 r2 k) *) (* FIXME - because of proofs, might have to use a xor instead *) | Ccompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompf") | Cnotcompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompf") - | Ccompfs _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompfs") - | Cnotcompfs _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompfs") (*| Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_float c rd r1 r2 in @@ -388,13 +404,7 @@ Definition transl_op OK (Pmulw rd rs1 rs2 ::i k) | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") -(*| Omulhs, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhw rd rs1 rs2 :: k) - | Omulhu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhuw rd rs1 rs2 :: k) -*)| Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") + | Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pdivw rd rs1 rs2 :: k) *) | Odivu, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odivu: 32-bits division not supported yet. Please use 64-bits.") @@ -483,25 +493,7 @@ Definition transl_op | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") -(*| Omullhs, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhl rd rs1 rs2 :: k) - | Omullhu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulhul rd rs1 rs2 :: k) - | Odivl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivl rd rs1 rs2 :: k) - | Odivlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivul rd rs1 rs2 :: k) - | Omodl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Preml rd rs1 rs2 :: k) - | Omodlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premul rd rs1 rs2 :: k) -*)| Oandl, a1 :: a2 :: nil => + | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 ::i k) | Oandlimm n, a1 :: nil => diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 9cba8402..2b79c78e 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -950,6 +950,7 @@ Proof. - 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_float32. exploreInst; try discriminate. - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. all: unfold transl_memory_access in EQ0; exploreInst; try discriminate. - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 175eca73..f7207c88 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -968,6 +968,36 @@ Proof. split; intros; Simpl. Qed. +Lemma swap_comparison_cmpfs: + forall v1 v2 cmp, + Val.lessdef (Val.cmpfs cmp v1 v2) (Val.cmpfs (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. + rewrite Float32.cmp_swap. auto. +Qed. + +Lemma transl_cond_float32_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_float32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmpfs cmp rs#r1 rs#r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpfs. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpfs. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + Lemma transl_cond_op_correct: forall cond rd args k c rs m, transl_cond_op cond rd args k = OK c -> @@ -1003,6 +1033,8 @@ Proof. exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpfloat *) + exploit transl_cond_float32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. Qed. (* diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c3473b9f..d9c22666 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -55,6 +55,7 @@ let arith_rr_str = function let arith_rrr_str = function | Pcompw it -> "Pcompw" | Pcompl it -> "Pcompl" + | Pfcompw ft -> "Pfcompw" | Paddw -> "Paddw" | Psubw -> "Psubw" | Pmulw -> "Pmulw" @@ -305,6 +306,10 @@ let alu_lite : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 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 + 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 in Array.of_list (List.map resmap resource_names) @@ -373,6 +378,7 @@ type real_instruction = | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz + | Fcompw let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -381,6 +387,7 @@ let ab_inst_to_real = function | "Pandl" | "Pandil" -> Andd | "Pcompw" | "Pcompiw" -> Compw | "Pcompl" | "Pcompil" -> Compd + | "Pfcompw" -> Fcompw | "Pmulw" -> Mulw | "Pmull" -> Muld | "Porw" | "Poriw" -> Orw @@ -470,6 +477,9 @@ let rec_to_usage r = | Compd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) + | Fcompw -> (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) | Make -> (match encoding with Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y @@ -502,7 +512,7 @@ let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make - | Sxwd | Zxwd + | Sxwd | Zxwd | Fcompw -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index acb128de..ac2e3b27 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -173,6 +173,18 @@ module Target (*: TARGET*) = | ITnone -> "none" let icond oc c = fprintf oc "%s" (icond_name c) + + let fcond_name = let open Asmblock in function + | FTone -> "one" + | FTueq -> "ueq" + | FToeq -> "oeq" + | FTune -> "une" + | FTolt -> "olt" + | FTuge -> "uge" + | FToge -> "oge" + | FTult -> "ult" + + let fcond oc c = fprintf oc "%s" (fcond_name c) let bcond_name = let open Asmblock in function | BTwnez -> "wnez" @@ -345,6 +357,9 @@ module Target (*: TARGET*) = | Pcompl (it, rd, rs1, rs2) -> fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 + | Pfcompw (ft, rd, rs1, rs2) -> + fprintf oc " fcompw.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 + | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> -- cgit From 5f7252105c9c639078ca3cc313502c647779d2f8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Mar 2019 17:25:48 +0100 Subject: Ajouté la négation des comparateurs single MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 4 ++-- mppa_k1c/Asmblockgenproof.v | 1 + mppa_k1c/Asmblockgenproof1.v | 40 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 42 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index fb6ba16e..73ecd67f 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -324,9 +324,9 @@ Definition transl_cond_op | Ccompfs c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (transl_cond_float32 c rd r1 r2 k) -(* | Cnotcompfs c, a1 :: a2 :: nil => + | Cnotcompfs c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_notfloat32 c rd r1 r2 k) *) (* FIXME - because of proofs, might have to use a xor instead *) + OK (transl_cond_notfloat32 c rd r1 r2 k) (* FIXME - because of proofs, might have to use a xor instead *) | Ccompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompf") | Cnotcompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompf") (*| Ccompf c, f1 :: f2 :: nil => diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 2b79c78e..1e3a40d4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -951,6 +951,7 @@ Proof. - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. unfold transl_cond_op in EQ0. 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: unfold transl_memory_access in EQ0; exploreInst; try discriminate. - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index f7207c88..e6093290 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -998,6 +998,42 @@ Proof. split; intros; Simpl. Qed. +Lemma transl_cond_nofloat32_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_notfloat32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpfs_bool cmp (rs r1) (rs r2)))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float32.cmp_ne_eq. auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float32.cmp_ne_eq. simpl. destruct (Float32.cmp Ceq f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float32.cmp Clt f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float32.cmp_swap. + destruct (Float32.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float32.cmp_swap. + destruct (Float32.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float32.cmp _ _ _); auto. +Qed. + Lemma transl_cond_op_correct: forall cond rd args k c rs m, transl_cond_op cond rd args k = OK c -> @@ -1033,8 +1069,10 @@ Proof. exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpfloat *) ++ (* cmpsingle *) exploit transl_cond_float32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpnosingle *) + exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. Qed. (* -- cgit From 59948b3348964f4b16f408ffe690f2c78ca80959 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 1 Mar 2019 17:41:27 +0100 Subject: Added double comparisons --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 15 +++++++- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 40 ++++++++++----------- mppa_k1c/Asmblockgenproof.v | 2 ++ mppa_k1c/Asmblockgenproof1.v | 70 ++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 9 +++-- mppa_k1c/TargetPrinter.ml | 2 ++ 8 files changed, 118 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 49f2d23c..31bc855d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -132,6 +132,7 @@ Inductive instruction : Type := | 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 *) @@ -253,6 +254,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 | PArithRRR (Asmblock.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmblock.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 | PArithRRR Asmblock.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 274d90a1..86c47613 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -331,7 +331,8 @@ Inductive arith_name_rf64 : Type := Inductive arith_name_rrr : Type := | Pcompw (it: itest) (**r comparison word *) | Pcompl (it: itest) (**r comparison long *) - | Pfcompw (it: ftest) (**r comparison float32 *) + | Pfcompw (ft: ftest) (**r comparison float32 *) + | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) | Psubw (**r sub word *) @@ -958,6 +959,17 @@ Definition compare_single (t: ftest) (v1 v2: val): val := | FTult => Val.notbool (Val.cmpfs Cge v1 v2) end. +Definition compare_float (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpf Ceq v1 v2 + | FTune => Val.cmpf Cne v1 v2 + | FTolt => Val.cmpf Clt v1 v2 + | FTuge => Val.notbool (Val.cmpf Clt v1 v2) + | FToge => Val.cmpf Cge v1 v2 + | FTult => Val.notbool (Val.cmpf Cge v1 v2) + end. + (** Execution of arith instructions TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... @@ -1029,6 +1041,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) | Pfcompw c => rs#d <- (compare_single c rs#s1 rs#s2) + | Pfcompl c => rs#d <- (compare_float c rs#s1 rs#s2) | Paddw => rs#d <- (Val.add rs#s1 rs#s2) | Psubw => rs#d <- (Val.sub rs#s1 rs#s2) | Pmulw => rs#d <- (Val.mul rs#s1 rs#s2) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 69d3d0cc..c2477e66 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -160,6 +160,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRR n, [Val v1; Val v2] => match n with | Pfcompw c => Some (Val (compare_single c v1 v2)) + | Pfcompl c => Some (Val (compare_float c v1 v2)) | Paddw => Some (Val (Val.add v1 v2)) | Psubw => Some (Val (Val.sub v1 v2)) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 73ecd67f..edffd879 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -294,6 +294,18 @@ Definition transl_cond_notfloat32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) | Reversed ft => Pfcompw ft rd r2 r1 ::i k end. +Definition transl_cond_float64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompl ft rd r1 r2 ::i k + | Reversed ft => Pfcompl ft rd r2 r1 ::i k + end. + +Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompl ft rd r1 r2 ::i k + | Reversed ft => Pfcompl ft rd r2 r1 ::i k + end. + Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -326,26 +338,14 @@ Definition transl_cond_op OK (transl_cond_float32 c rd r1 r2 k) | Cnotcompfs c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_notfloat32 c rd r1 r2 k) (* FIXME - because of proofs, might have to use a xor instead *) - | Ccompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Ccompf") - | Cnotcompf _, _ => Error(msg "Asmblockgen.transl_cond_op: Cnotcompf") -(*| Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) -*)| _, _ => + OK (transl_cond_notfloat32 c rd r1 r2 k) + | Ccompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_float64 c rd r1 r2 k) + | Cnotcompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_notfloat64 c rd r1 r2 k) + | _, _ => Error(msg "Asmblockgen.transl_cond_op") end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1e3a40d4..1ac9a211 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -950,6 +950,8 @@ Proof. - 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. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e6093290..76404257 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1034,6 +1034,72 @@ Proof. destruct (Float32.cmp _ _ _); auto. Qed. +Lemma swap_comparison_cmpf: + forall v1 v2 cmp, + Val.lessdef (Val.cmpf cmp v1 v2) (Val.cmpf (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. + rewrite Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_float64_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_float64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmpf cmp rs#r1 rs#r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpf. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpf. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_nofloat64_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_notfloat64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpf_bool cmp (rs r1) (rs r2)))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float.cmp_ne_eq. auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float.cmp_ne_eq. simpl. destruct (Float.cmp Ceq f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float.cmp Clt f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float.cmp_swap. + destruct (Float.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float.cmp_swap. + destruct (Float.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float.cmp _ _ _); auto. +Qed. + Lemma transl_cond_op_correct: forall cond rd args k c rs m, transl_cond_op cond rd args k = OK c -> @@ -1069,6 +1135,10 @@ Proof. exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpfloat *) + exploit transl_cond_float64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpnosingle *) + exploit transl_cond_nofloat64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. + (* cmpsingle *) exploit transl_cond_float32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. + (* cmpnosingle *) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index d9c22666..db50e3a5 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -56,6 +56,7 @@ let arith_rrr_str = function | Pcompw it -> "Pcompw" | Pcompl it -> "Pcompl" | Pfcompw ft -> "Pfcompw" + | Pfcompl ft -> "Pfcompl" | Paddw -> "Paddw" | Psubw -> "Psubw" | Pmulw -> "Pmulw" @@ -378,7 +379,7 @@ type real_instruction = | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz - | Fcompw + | Fcompw | Fcompd let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw @@ -388,6 +389,7 @@ let ab_inst_to_real = function | "Pcompw" | "Pcompiw" -> Compw | "Pcompl" | "Pcompil" -> Compd | "Pfcompw" -> Fcompw + | "Pfcompl" -> Fcompd | "Pmulw" -> Mulw | "Pmull" -> Muld | "Porw" | "Poriw" -> Orw @@ -480,6 +482,9 @@ let rec_to_usage r = | Fcompw -> (match encoding with None -> alu_lite | Some U6 | Some S10 | Some U27L5 -> alu_lite_x | _ -> raise InvalidEncoding) + | Fcompd -> (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) | Make -> (match encoding with Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y @@ -512,7 +517,7 @@ let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make - | Sxwd | Zxwd | Fcompw + | Sxwd | Zxwd | Fcompw | Fcompd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ac2e3b27..5d59e7d2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -359,6 +359,8 @@ module Target (*: TARGET*) = | Pfcompw (ft, rd, rs1, rs2) -> fprintf oc " fcompw.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 + | Pfcompl (ft, rd, rs1, rs2) -> + fprintf oc " fcompd.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 -- cgit From 55d62972391310a71e7bc0eff362fc339455b23b Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 2 Mar 2019 09:22:37 +0100 Subject: (Unsafe) coercion of ??bool into bool --- mppa_k1c/Asmblockdeps.v | 17 +++++++++++++++++ mppa_k1c/abstractbb/Impure/ImpConfig.v | 4 ++-- 2 files changed, 19 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c2477e66..80383c2f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1313,6 +1313,7 @@ Admitted. (* FIXME - à voir avec Sylvain *) Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. + Inductive bblock_equiv' (bb bb': L.bblock) := | bblock_equiv_intro': (forall s, exec Ge bb s = exec Ge bb' s) -> @@ -1329,6 +1330,22 @@ Axiom bblock_equiv'_eq: forall b1 b2, bblock_equivb b1 b2 = true <-> bblock_equiv' b1 b2. (* FIXME - à voir avec Sylvain *) + +(* Coerce bblock_eq_test into a pure function (this is a little unsafe like all oracles in CompCert). *) + +Import UnsafeImpure. + +Definition pure_bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock): bool := unsafe_coerce (bblock_eq_test verb p1 p2). + +Theorem pure_bblock_eq_test_correct verb p1 p2: + forall ge fn, Ge = Genv ge fn -> + pure_bblock_eq_test verb p1 p2 = true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. +Proof. + intros; unfold pure_bblock_eq_test. intros; eapply bblock_eq_test_correct; eauto. + apply unsafe_coerce_not_really_correct; eauto. +Qed. + + End SECT. Extract Constant bblock_equivb => "PostpassSchedulingOracle.bblock_equivb'". diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index 55931e0f..3d807c4e 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -19,7 +19,7 @@ Module Type ImpureView. *) -(* +(* *) Module UnsafeImpure. Parameter unsafe_coerce: forall {A}, t A -> A. @@ -27,7 +27,7 @@ Module Type ImpureView. Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. End UnsafeImpure. -*) +(* *) End ImpureView. -- cgit From e9859d89510e6593c83f954b8b9580fff0dd51f4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 Mar 2019 17:36:07 +0100 Subject: bblock_equiv_reduce Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 46 ++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 42 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 80383c2f..bb800b99 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -10,6 +10,7 @@ Require Import Floats. Require Import ZArith. Require Import Coqlib. Require Import ImpDep. +Require Import Axioms. Open Scope impure. @@ -648,6 +649,12 @@ Definition match_states (s: Asmblock.state) (s': state) := s' pmem = Memstate m /\ forall r, s' (#r) = Val (rs r). +Definition match_outcome (o:outcome) (s: option state) := + match o with + | Next rs m => exists s', s=Some s' /\ match_states (State rs m) s' + | Stuck => s=None + end. + Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). Definition trans_state (s: Asmblock.state) : state := @@ -673,12 +680,13 @@ Qed. Lemma not_eq_add: forall k n n', n <> n' -> k + n <> k + n'. Proof. -Admitted. (* FIXME - help Sylvain ? *) + intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. +Qed. Lemma not_eq_ireg_to_pos: forall n r r', r' <> r -> n + ireg_to_pos r <> n + ireg_to_pos r'. Proof. - intros. destruct r; destruct r'; try contradiction; apply not_eq_add; discriminate. (* FIXME - quite long to prove *) + intros. destruct r; destruct r'; try contradiction; apply not_eq_add; discriminate. Qed. Lemma not_eq_ireg_ppos: @@ -1268,12 +1276,42 @@ Proof. - congruence. Qed. +Axiom forward_simu_alt: + forall rs1 m1 s1' b ge fn, + Ge = Genv ge fn -> + match_states (State rs1 m1) s1' -> + match_outcome (exec_bblock ge fn b rs1 m1) (exec Ge (trans_block b) s1'). -Axiom bblock_equiv_reduce: +Local Hint Resolve trans_state_match. + +Lemma bblock_equiv_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_equiv Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_equiv ge fn p1 p2. (* FIXME *) + Asmblockgenproof0.bblock_equiv ge fn p1 p2. +Proof. + unfold bblock_equiv, res_eq; intros p1 p2 ge fn H1 H2; constructor. + intros rs m. + generalize (H2 (trans_state (State rs m))); clear H2. + intro H2. + exploit (forward_simu_alt rs m (trans_state (State rs m)) p1 ge fn); eauto. + exploit (forward_simu_alt rs m (trans_state (State rs m)) p2 ge fn); eauto. + remember (exec_bblock ge fn p1 rs m) as exp1. + destruct exp1. + + (* Next *) + intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. + destruct H2 as (m2' & H2 & H4). rewrite H2 in H3. + destruct (exec_bblock ge fn p2 rs m); simpl in H3. + * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. + cutrewrite (rs0=rs1). + - cutrewrite (m0=m1); auto. congruence. + - apply functional_extensionality. intros r. + generalize (H0 r). intros Hr. congruence. + * discriminate. + + intros MO MO2. remember (trans_state (State rs m)) as s1. inversion MO2. clear MO2. unfold exec in *. + rewrite H0 in H2. clear H0. destruct (exec_bblock ge fn p2 rs m); auto. rewrite H2 in MO. unfold match_outcome in MO. + destruct MO as (? & ? & ?). discriminate. +Qed. Definition string_of_name (x: P.R.t): ?? pstring := RET (Str ("resname")). (* match x with -- cgit From cd69b24565713610d0ea5a613f4871af6e18e9d4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 10:48:03 +0100 Subject: No more axiom remaining in PostpassScheduling.v (but still a couple remaining in Asmblockdeps) --- mppa_k1c/Asmblockdeps.v | 2 +- mppa_k1c/PostpassScheduling.v | 98 +++++++++++++++++++++++++------------- mppa_k1c/PostpassSchedulingproof.v | 12 ----- 3 files changed, 66 insertions(+), 46 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index bb800b99..4f10406f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1366,7 +1366,7 @@ Axiom bblock_equivb: L.bblock -> L.bblock -> bool. Axiom bblock_equiv'_eq: forall b1 b2, - bblock_equivb b1 b2 = true <-> bblock_equiv' b1 b2. (* FIXME - à voir avec Sylvain *) + bblock_equivb b1 b2 = true -> bblock_equiv' b1 b2. (* FIXME - à voir avec Sylvain *) (* Coerce bblock_eq_test into a pure function (this is a little unsafe like all oracles in CompCert). *) diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index fa0ebfe6..0c1cf605 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -33,13 +33,6 @@ Definition exec := exec_bblock. Definition bblock_equivb' := bblock_equivb. -Lemma bblock_equivb'_refl (ge: Genv.t fundef unit) (fn: function): forall tbb, bblock_equivb' tbb tbb = true. -Proof. - intros. rewrite bblock_equiv'_eq. apply bblock_equiv'_refl. - Unshelve. (* FIXME - problem of Genv and function *) - constructor; auto. -Qed. - Lemma trans_equiv_stuck: forall b1 b2 ge fn rs m, bblock_equiv' (P.Genv ge fn) (trans_block b1) (trans_block b2) -> @@ -54,7 +47,6 @@ Proof. reflexivity. eassumption. eassumption. Qed. - Lemma bblock_equiv'_comm: forall ge fn b1 b2, bblock_equiv' (P.Genv ge fn) b1 b2 <-> bblock_equiv' (P.Genv ge fn) b2 b1. @@ -270,13 +262,6 @@ Definition verify_schedule (bb bb' : bblock) : res unit := | false => Error (msg "PostpassScheduling.verify_schedule") end. -Lemma verify_schedule_refl (ge: Genv.t fundef unit) (fn: function): - forall bb, verify_schedule bb bb = OK tt. -Proof. - intros. unfold verify_schedule. rewrite bblock_equivb'_refl. reflexivity. all: auto. -Qed. - - Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). @@ -397,7 +382,7 @@ Qed. Definition do_schedule (bb: bblock) : list bblock := if (Z.eqb (size bb) 1) then bb::nil else schedule bb. -Definition verified_schedule (bb : bblock) : res (list bblock) := +Definition verified_schedule_nob (bb : bblock) : res (list bblock) := let bb' := no_header bb in let lbb := do_schedule bb' in do tbb <- concat_all lbb; @@ -405,22 +390,48 @@ Definition verified_schedule (bb : bblock) : res (list bblock) := do schedcheck <- verify_schedule bb' tbb; stick_header_code (header bb) lbb. -Lemma verified_schedule_size: - forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. +Lemma verified_schedule_nob_size: + forall bb lbb, verified_schedule_nob bb = OK lbb -> size bb = size_blocks lbb. Proof. intros. monadInv H. erewrite <- stick_header_code_size; eauto. apply verify_size_size. destruct x0; try discriminate. assumption. Qed. -Lemma verified_schedule_single_inst (ge: Genv.t fundef unit) (fn: function): - forall bb, size bb = 1 -> verified_schedule bb = OK (bb::nil). +Lemma verified_schedule_nob_no_header_in_middle: + forall lbb bb, + verified_schedule_nob bb = OK lbb -> + Forall (fun b => header b = nil) (tail lbb). Proof. - intros. unfold verified_schedule. - unfold do_schedule. rewrite no_header_size. rewrite H. simpl. - unfold verify_size. simpl. rewrite no_header_size. rewrite Z.add_0_r. cutrewrite (size bb =? size bb = true). rewrite verify_schedule_refl. simpl. - apply stick_header_code_no_header. all: auto. - rewrite H. reflexivity. + intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. + eapply concat_all_no_header_in_middle. eassumption. +Qed. + +Lemma verified_schedule_nob_header: + forall bb tbb lbb, + verified_schedule_nob bb = OK (tbb :: lbb) -> + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. +Proof. + intros. split. + - 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. + + +Definition verified_schedule (bb : bblock) : res (list bblock) := + match exit bb with + | Some (PExpand (Pbuiltin ef args res)) => OK (bb::nil) (* Special case for ensuring the lemma verified_schedule_builtin_idem *) + | _ => verified_schedule_nob bb + end. + +Lemma verified_schedule_size: + forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + all: try (apply verified_schedule_nob_size; auto; fail). + destruct i. inv H. simpl. omega. Qed. Lemma verified_schedule_no_header_in_middle: @@ -428,8 +439,9 @@ Lemma verified_schedule_no_header_in_middle: verified_schedule bb = OK lbb -> Forall (fun b => header b = nil) (tail lbb). Proof. - intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. - eapply concat_all_no_header_in_middle. eassumption. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + all: try (eapply verified_schedule_nob_no_header_in_middle; eauto; fail). + destruct i. inv H. simpl. auto. Qed. Lemma verified_schedule_header: @@ -438,15 +450,15 @@ Lemma verified_schedule_header: header bb = header tbb /\ Forall (fun b => header b = nil) lbb. Proof. - intros. split. - - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. - simpl. reflexivity. - - apply verified_schedule_no_header_in_middle in H. assumption. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + all: try (eapply verified_schedule_nob_header; eauto; fail). + destruct i. inv H. split; simpl; auto. Qed. -Theorem verified_schedule_correct: + +Lemma verified_schedule_nob_correct: forall ge f bb lbb, - verified_schedule bb = OK lbb -> + verified_schedule_nob bb = OK lbb -> exists tbb, concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. @@ -460,6 +472,26 @@ Proof. destruct (bblock_equivb _ _); 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 + /\ bblock_equiv ge f bb tbb. +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + all: try (eapply verified_schedule_nob_correct; eauto; fail). + destruct i. inv H. eexists. split; simpl; auto. constructor; auto. +Qed. + +Lemma verified_schedule_builtin_idem: + forall bb ef args res lbb, + exit bb = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bb = OK lbb -> + lbb = bb :: nil. +Proof. + intros. unfold verified_schedule in H0. rewrite H in H0. inv H0. reflexivity. +Qed. Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2ecb494d..f969e5b4 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -38,18 +38,6 @@ Proof. eapply H1; eauto. Qed. -Lemma verified_schedule_builtin_idem (ge: Genv.t fundef unit) (fn: function): - forall bb ef args res lbb, - exit bb = Some (PExpand (Pbuiltin ef args res)) -> - verified_schedule bb = OK lbb -> - lbb = bb :: nil. -Proof. - intros. exploit builtin_body_nil; eauto. intros. - rewrite verified_schedule_single_inst in H0; auto. - - inv H0. auto. - - unfold size. rewrite H. rewrite H1. simpl. auto. -Qed. - Lemma exec_body_app: forall l l' ge rs m rs'' m'', exec_body ge (l ++ l') rs m = Next rs'' m'' -> -- cgit From 9833210392b7bddf740e6b555ce931efb46cf387 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 5 Mar 2019 11:02:51 +0100 Subject: remove cumbersome dependency on genv in bblock_eq_test --- mppa_k1c/Asmblockdeps.v | 34 +++++++++++++++++++----- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 5 ++++ mppa_k1c/abstractbb/DepTreeTheory.v | 10 +++---- mppa_k1c/abstractbb/ImpDep.v | 39 +++++++++++++--------------- 4 files changed, 55 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4f10406f..273ccb68 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -379,6 +379,29 @@ Definition op_eval (o: op) (l: list value) := | _, _ => None end. + +Definition is_constant (o: op): bool := + (* FIXME + + => répondre "true" autant que possible mais en satisfaisant [is_constant_correct] ci-dessous. + + ATTENTION, is_constant ne doit pas dépendre de [ge]. + Sinon, on aurait une implémentation facile: [match op_eval o nil with Some _ => true | _ => false end] + + => REM: il n'est pas sûr que ce soit utile de faire qqchose de très exhaustif en pratique... + (ça sert juste à une petite optimisation du vérificateur de scheduling). + *) + match o with + | Constant _ => true + | _ => false + end. + +Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None. +Proof. + destruct o; simpl; try congruence. +Qed. + + Definition iandb (ib1 ib2: ?? bool): ?? bool := DO b1 <~ ib1;; DO b2 <~ ib2;; @@ -483,6 +506,7 @@ Proof. Qed. End IMPPARAM. + End P. Module L <: ISeqLanguage with Module LP:=P. @@ -1335,19 +1359,17 @@ Definition string_of_op (op: P.op): ?? pstring := RET (Str ("OP")). Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op Ge (trans_block p1) (trans_block p2) + IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) else - IDT.bblock_eq_test Ge (trans_block p1) (trans_block p2). + IDT.bblock_eq_test (trans_block p1) (trans_block p2). Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. Theorem bblock_eq_test_correct verb p1 p2 : - forall ge fn, Ge = Genv ge fn -> - WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. + WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. Proof. - intros ge fn genv_eq. wlp_simplify. -Admitted. (* FIXME - à voir avec Sylvain *) +Qed. Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 21e7bd98..904fb72c 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -29,6 +29,11 @@ Parameter genv: Type. (* environment to be used for evaluating an op *) *) 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. diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index 6f017378..353e9160 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -129,19 +129,17 @@ with list_exp_tree (le: list_exp) (d old: deps): list_tree := Definition failsafe (t: tree): bool := match t with | Tname x => true - | Top o Tnil => - match op_eval ge o nil with - | Some _ => true - | None => false - end + | Top o Tnil => is_constant o | _ => false end. +Local Hint Resolve is_constant_correct. + Lemma failsafe_correct (t: tree) m: failsafe t = true -> tree_eval t m <> None. Proof. destruct t; simpl; try congruence. destruct l; simpl; try congruence. - destruct (op_eval ge o nil); try congruence. + eauto. Qed. Fixpoint macro_deps (i: macro) (d old: deps): deps := diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 994c8e34..0cce7ce3 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -215,7 +215,7 @@ Fixpoint hmacro_deps (i: macro) (d od: hdeps): ?? hdeps := | (x, e)::i' => DO dbg <~ debug_assign x;; DO t0 <~ hdeps_get d x None;; - DO v' <~ (if failsafe ge (data t0) + DO v' <~ (if failsafe (data t0) then hexp_tree e d od dbg else @@ -248,16 +248,16 @@ Lemma hmacro_deps_correct i: forall d1 od1, WHEN hmacro_deps i d1 od1 ~> d1' THEN forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> (forall x, pdeps_get d1 x = deps_get d2 x) -> - forall x, pdeps_get d1' x = deps_get (macro_deps ge i d2 od2) x. + forall x, pdeps_get d1' x = deps_get (macro_deps i d2 od2) x. Proof. induction i; simpl; wlp_simplify. - + cutrewrite (failsafe ge (deps_get d2 a0) = failsafe ge (data exta0)). + + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). - erewrite H0, H2; simpl; eauto. clear exta2 Hexta2 H2; auto. intros x0; destruct (R.eq_dec a0 x0). * subst. autorewrite with dict_rw. rewrite set_spec_eq. erewrite H1; eauto. * rewrite set_spec_diff, pset_spec_diff; auto. - rewrite H, H4; auto. - + cutrewrite (failsafe ge (deps_get d2 a0) = failsafe ge (data exta0)). + + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). - erewrite H0, H3; simpl; eauto. clear exta3 Hexta3 H3; auto. intros x0; destruct (R.eq_dec a0 x0). * subst; autorewrite with dict_rw. rewrite H2. @@ -282,7 +282,7 @@ Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := Lemma hbblock_deps_rec_correct p: forall d1, WHEN hbblock_deps_rec p d1 ~> d1' THEN - forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec ge p d2) x. + forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec p d2) x. Proof. induction p; simpl; wlp_simplify. Qed. @@ -294,7 +294,7 @@ Definition hbblock_deps: bblock -> ?? hdeps := fun p => hbblock_deps_rec p Dict.empty. Lemma hbblock_deps_correct p: - WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps ge p) x. + WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps p) x. Proof. unfold bblock_deps; wlp_simplify. erewrite H; eauto. intros; autorewrite with dict_rw; auto. rewrite empty_spec. reflexivity. @@ -375,7 +375,6 @@ Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 macros *) Variable dbg2: R.t -> ?? option pstring. (* log of p2 macros *) Variable log1: unit -> ?? unit. (* log of p1 macros *) Variable log2: unit -> ?? unit. (* log of p2 macros *) -Variable ge: genv. Variable hco_tree: hashConsing tree. @@ -388,8 +387,8 @@ Variable print_error: pstring -> ?? unit. Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := DO r <~ (TRY - DO d1 <~ hbblock_deps (hC hco_tree) (hC hco_list) ge dbg1 log1 p1 ;; - DO d2 <~ hbblock_deps (hC_known hco_tree) (hC_known hco_list) ge dbg2 log2 p2 ;; + 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 RET true else ( @@ -399,7 +398,7 @@ Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := CATCH_FAIL s, _ => print_error s;; RET false - ENSURE (fun b => b=true -> bblock_equiv ge p1 p2));; + ENSURE (fun b => b=true -> forall ge, bblock_equiv ge p1 p2));; RET (`r). Obligation 1. destruct hco_tree_correct as [X1 X2], hco_list_correct as [Y1 Y2]. @@ -410,7 +409,7 @@ Obligation 1. Qed. Theorem g_bblock_eq_test_correct p1 p2: - WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. + WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. Proof. wlp_simplify. destruct exta; simpl in * |- *; auto. @@ -439,11 +438,11 @@ Definition print_error (log: logger unit) (s:pstring): ?? unit println (msg_prefix +; msg_number +; n +; " -- " +; s). -Program Definition bblock_eq_test (ge: genv) (p1 p2: bblock): ?? bool := +Program Definition bblock_eq_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_eq_test no_dbg no_dbg skip (log_insert log) ge hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. + g_bblock_eq_test no_dbg no_dbg skip (log_insert log) hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. Obligation 1. generalize (hCons_correct _ _ _ _ H0); clear H0. constructor 1; wlp_simplify. @@ -455,8 +454,8 @@ Qed. Local Hint Resolve g_bblock_eq_test_correct. -Theorem bblock_eq_test_correct ge p1 p2: - WHEN bblock_eq_test ge p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. +Theorem bblock_eq_test_correct p1 p2: + WHEN bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. Proof. wlp_simplify. Qed. @@ -690,7 +689,7 @@ Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing lis next_log hcl s ). -Program Definition verb_bblock_eq_test (ge: genv) (p1 p2: bblock): ?? bool := +Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref Nothing;; @@ -701,7 +700,6 @@ Program Definition verb_bblock_eq_test (ge: genv) (p1 p2: bblock): ?? bool := simple_debug (hlog log1 hco_tree hco_list) (log_insert log2) - ge hco_tree _ hco_list _ (print_error_end1 hco_tree hco_list) @@ -719,8 +717,7 @@ Program Definition verb_bblock_eq_test (ge: genv) (p1 p2: bblock): ?? bool := (log_debug log1) simple_debug (hlog log1 hco_tree hco_list) - (log_insert log2) - ge + (log_insert log2) hco_tree _ hco_list _ (print_error_end2 hco_tree hco_list) @@ -749,8 +746,8 @@ Obligation 4. constructor 1; wlp_simplify. Qed. -Theorem verb_bblock_eq_test_correct ge p1 p2: - WHEN verb_bblock_eq_test ge p1 p2 ~> b THEN b=true -> bblock_equiv ge p1 p2. +Theorem verb_bblock_eq_test_correct p1 p2: + WHEN verb_bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. Proof. wlp_simplify. Qed. -- cgit From 6c51fda9e503953a4f8ca3e2448b8040158ddc94 Mon Sep 17 00:00:00 2001 From: tvdd Date: Tue, 5 Mar 2019 11:09:52 +0100 Subject: add_to_code_is_trans_code proof --- mppa_k1c/Machblockgen.v | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 18abb927..7206fb51 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -126,7 +126,15 @@ Inductive is_trans_code: Mach.code -> code -> Prop := is_trans_code c (bh::bl) -> trans_inst i = MB_basic bi -> header bh = nil -> - is_trans_code (i::c) (add_basic bi bh::bl). + is_trans_code (i::c) (add_basic bi bh::bl) + | Tr_empty_bblock c bh bl: + is_trans_code c bl -> + bh = empty_bblock -> + is_trans_code c (bh::bl) + | Tr_cfi i bi c bl: + is_trans_code c bl -> + trans_inst i = MB_cfi bi -> + is_trans_code (i::c) (cfi_bblock bi :: bl). Local Hint Resolve Tr_nil Tr_end_block. @@ -135,12 +143,15 @@ Lemma add_to_code_is_trans_code i c bl: is_trans_code (i::c) (add_to_code (trans_inst i) bl). Proof. destruct bl as [|bh0 bl]; simpl. - - intro H; inversion H; subst; eauto. + - intro H. inversion H. subst. eauto. - remember (trans_inst i) as ti. destruct ti as [l|bi|cfi]. + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. - + -Admitted. (* A FINIR *) + + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. + * eapply Tr_add_basic; eauto. + * eapply Tr_add_basic; eauto. eapply Tr_empty_bblock. eauto. reflexivity. + + intros. eapply Tr_cfi. eauto. symmetry in Heqti. eauto. +Qed. (* A FINIR *) Local Hint Resolve add_to_code_is_trans_code. -- cgit From 60e11de044fc3fa913e9ce040ee036354eb15659 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 11:10:15 +0100 Subject: forward_simu_alt proof Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 273ccb68..4912a96f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1300,11 +1300,16 @@ Proof. - congruence. Qed. -Axiom forward_simu_alt: +Theorem forward_simu_alt: forall rs1 m1 s1' b ge fn, Ge = Genv ge fn -> match_states (State rs1 m1) s1' -> match_outcome (exec_bblock ge fn b rs1 m1) (exec Ge (trans_block b) s1'). +Proof. + intros until fn. intros GENV MS. destruct (exec_bblock _ _ _ _ _) eqn:EXEB. + - eapply forward_simu; eauto. + - eapply forward_simu_stuck; eauto. +Qed. Local Hint Resolve trans_state_match. -- cgit From e1db6ccc92de401bf1973fa185ac6ed0703b615e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 11:18:01 +0100 Subject: [BROKEN] error with the new is_constant and is_constant_correct --- mppa_k1c/Asmblockdeps.v | 34 ++++++++-------------------------- 1 file changed, 8 insertions(+), 26 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4912a96f..2bf12c89 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -379,28 +379,9 @@ Definition op_eval (o: op) (l: list value) := | _, _ => None end. +Definition is_constant (o: op) := false. -Definition is_constant (o: op): bool := - (* FIXME - - => répondre "true" autant que possible mais en satisfaisant [is_constant_correct] ci-dessous. - - ATTENTION, is_constant ne doit pas dépendre de [ge]. - Sinon, on aurait une implémentation facile: [match op_eval o nil with Some _ => true | _ => false end] - - => REM: il n'est pas sûr que ce soit utile de faire qqchose de très exhaustif en pratique... - (ça sert juste à une petite optimisation du vérificateur de scheduling). - *) - match o with - | Constant _ => true - | _ => false - end. - -Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None. -Proof. - destruct o; simpl; try congruence. -Qed. - +Axiom is_constant_correct : forall (ge : genv) (o : op), is_constant o = true -> op_eval o [] <> None. Definition iandb (ib1 ib2: ?? bool): ?? bool := DO b1 <~ ib1;; @@ -506,7 +487,6 @@ Proof. Qed. End IMPPARAM. - End P. Module L <: ISeqLanguage with Module LP:=P. @@ -1364,17 +1344,19 @@ Definition string_of_op (op: P.op): ?? pstring := RET (Str ("OP")). Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) + IDT.verb_bblock_eq_test string_of_name string_of_op Ge (trans_block p1) (trans_block p2) else - IDT.bblock_eq_test (trans_block p1) (trans_block p2). + IDT.bblock_eq_test Ge (trans_block p1) (trans_block p2). Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. Theorem bblock_eq_test_correct verb p1 p2 : - WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. + forall ge fn, Ge = Genv ge fn -> + WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. Proof. + intros ge fn genv_eq. wlp_simplify. -Qed. +Admitted. (* FIXME - à voir avec Sylvain *) Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. -- cgit From 50092ae8d8937cb5771c890dd608ac961ce32440 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 11:21:47 +0100 Subject: C'est moi qui avait fait des betises avec CoqIDE, ça remarche MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockdeps.v | 34 ++++++++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2bf12c89..4912a96f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -379,9 +379,28 @@ Definition op_eval (o: op) (l: list value) := | _, _ => None end. -Definition is_constant (o: op) := false. -Axiom is_constant_correct : forall (ge : genv) (o : op), is_constant o = true -> op_eval o [] <> None. +Definition is_constant (o: op): bool := + (* FIXME + + => répondre "true" autant que possible mais en satisfaisant [is_constant_correct] ci-dessous. + + ATTENTION, is_constant ne doit pas dépendre de [ge]. + Sinon, on aurait une implémentation facile: [match op_eval o nil with Some _ => true | _ => false end] + + => REM: il n'est pas sûr que ce soit utile de faire qqchose de très exhaustif en pratique... + (ça sert juste à une petite optimisation du vérificateur de scheduling). + *) + match o with + | Constant _ => true + | _ => false + end. + +Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None. +Proof. + destruct o; simpl; try congruence. +Qed. + Definition iandb (ib1 ib2: ?? bool): ?? bool := DO b1 <~ ib1;; @@ -487,6 +506,7 @@ Proof. Qed. End IMPPARAM. + End P. Module L <: ISeqLanguage with Module LP:=P. @@ -1344,19 +1364,17 @@ Definition string_of_op (op: P.op): ?? pstring := RET (Str ("OP")). Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op Ge (trans_block p1) (trans_block p2) + IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) else - IDT.bblock_eq_test Ge (trans_block p1) (trans_block p2). + IDT.bblock_eq_test (trans_block p1) (trans_block p2). Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. Theorem bblock_eq_test_correct verb p1 p2 : - forall ge fn, Ge = Genv ge fn -> - WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. + WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. Proof. - intros ge fn genv_eq. wlp_simplify. -Admitted. (* FIXME - à voir avec Sylvain *) +Qed. Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. -- cgit From 0d709513e08aa36faae2fe3d006e7e4c23aa4aff Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 5 Mar 2019 11:26:51 +0100 Subject: m --- mppa_k1c/Machblockgen.v | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 7206fb51..0a8b2ccd 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -126,7 +126,8 @@ Inductive is_trans_code: Mach.code -> code -> Prop := is_trans_code c (bh::bl) -> trans_inst i = MB_basic bi -> header bh = nil -> - is_trans_code (i::c) (add_basic bi bh::bl) + is_trans_code (i::c) (add_basic bi bh::bl). +(* Use Tr_end_block instead of: | Tr_empty_bblock c bh bl: is_trans_code c bl -> bh = empty_bblock -> @@ -135,6 +136,7 @@ Inductive is_trans_code: Mach.code -> code -> Prop := is_trans_code c bl -> trans_inst i = MB_cfi bi -> is_trans_code (i::c) (cfi_bblock bi :: bl). +*) Local Hint Resolve Tr_nil Tr_end_block. @@ -149,9 +151,12 @@ Proof. + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. * eapply Tr_add_basic; eauto. - * eapply Tr_add_basic; eauto. eapply Tr_empty_bblock. eauto. reflexivity. - + intros. eapply Tr_cfi. eauto. symmetry in Heqti. eauto. -Qed. (* A FINIR *) + * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. + rewrite Heqti; eapply Tr_end_block; eauto. + rewrite <- Heqti. + eapply End_basic. + (* + intros. eapply Tr_cfi. eauto. symmetry in Heqti. eauto. *) +Admitted. (* A FINIR *) Local Hint Resolve add_to_code_is_trans_code. -- cgit From be56a34df35fcebdf723c204f83b1208c92e0b77 Mon Sep 17 00:00:00 2001 From: tvdd Date: Tue, 5 Mar 2019 11:49:32 +0100 Subject: add_to_code_is_trans_code proof 2 --- mppa_k1c/Machblockgen.v | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index 0a8b2ccd..fb63c78c 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -127,16 +127,6 @@ Inductive is_trans_code: Mach.code -> code -> Prop := trans_inst i = MB_basic bi -> header bh = nil -> is_trans_code (i::c) (add_basic bi bh::bl). -(* Use Tr_end_block instead of: - | Tr_empty_bblock c bh bl: - is_trans_code c bl -> - bh = empty_bblock -> - is_trans_code c (bh::bl) - | Tr_cfi i bi c bl: - is_trans_code c bl -> - trans_inst i = MB_cfi bi -> - is_trans_code (i::c) (cfi_bblock bi :: bl). -*) Local Hint Resolve Tr_nil Tr_end_block. @@ -153,10 +143,12 @@ Proof. * eapply Tr_add_basic; eauto. * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. rewrite Heqti; eapply Tr_end_block; eauto. - rewrite <- Heqti. - eapply End_basic. - (* + intros. eapply Tr_cfi. eauto. symmetry in Heqti. eauto. *) -Admitted. (* A FINIR *) + rewrite <- Heqti. eapply End_basic. congruence. + + intros. + cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. + rewrite Heqti. eapply Tr_end_block; eauto. + rewrite <- Heqti. eapply End_cfi. congruence. +Qed. Local Hint Resolve add_to_code_is_trans_code. -- cgit From 264637042f4e648888307af28392aea21e2f28b8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 11:51:49 +0100 Subject: No more axioms remaining (scheduling completely proven), however error at extraction --- mppa_k1c/Asmblockdeps.v | 24 +++-------------- mppa_k1c/PostpassScheduling.v | 60 +++++-------------------------------------- 2 files changed, 10 insertions(+), 74 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4912a96f..63ccdeac 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1375,27 +1375,8 @@ Theorem bblock_eq_test_correct verb p1 p2 : Proof. wlp_simplify. Qed. -Global Opaque bblock_eq_test. Hint Resolve bblock_eq_test_correct: wlp. - -Inductive bblock_equiv' (bb bb': L.bblock) := - | bblock_equiv_intro': - (forall s, exec Ge bb s = exec Ge bb' s) -> - bblock_equiv' bb bb'. - -Lemma bblock_equiv'_refl: forall tbb, bblock_equiv' tbb tbb. -Proof. - repeat constructor. -Qed. - -Axiom bblock_equivb: L.bblock -> L.bblock -> bool. - -Axiom bblock_equiv'_eq: - forall b1 b2, - bblock_equivb b1 b2 = true -> bblock_equiv' b1 b2. (* FIXME - à voir avec Sylvain *) - - (* Coerce bblock_eq_test into a pure function (this is a little unsafe like all oracles in CompCert). *) Import UnsafeImpure. @@ -1410,7 +1391,8 @@ Proof. apply unsafe_coerce_not_really_correct; eauto. Qed. +Definition bblock_equivb: Asmblock.bblock -> Asmblock.bblock -> bool := pure_bblock_eq_test true. -End SECT. +Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. -Extract Constant bblock_equivb => "PostpassSchedulingOracle.bblock_equivb'". +End SECT. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 0c1cf605..373c6a1b 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -31,54 +31,6 @@ Definition exec' := L.run. Definition exec := exec_bblock. -Definition bblock_equivb' := bblock_equivb. - -Lemma trans_equiv_stuck: - forall b1 b2 ge fn rs m, - bblock_equiv' (P.Genv ge fn) (trans_block b1) (trans_block b2) -> - (exec ge fn b1 rs m = Stuck <-> exec ge fn b2 rs m = Stuck). -Proof. - intros. inv H. - pose (trans_state_match (State rs m)). - split. - - intros. eapply forward_simu_stuck in H; eauto. rewrite H0 in H. eapply trans_block_reverse_stuck. - reflexivity. eassumption. eassumption. - - intros. eapply forward_simu_stuck in H; eauto. rewrite <- H0 in H. eapply trans_block_reverse_stuck. - reflexivity. eassumption. eassumption. -Qed. - -Lemma bblock_equiv'_comm: - forall ge fn b1 b2, - bblock_equiv' (P.Genv ge fn) b1 b2 <-> bblock_equiv' (P.Genv ge fn) b2 b1. -Proof. - intros. repeat constructor. all: inv H; congruence. -Qed. - -Theorem trans_exec: - forall b1 b2 ge f, bblock_equiv' (P.Genv ge f) (trans_block b1) (trans_block b2) -> bblock_equiv ge f b1 b2. -Proof. - repeat constructor. intros rs1 m1. - destruct (exec_bblock _ _ b1 _ _) as [rs2 m2|] eqn:EXEB; destruct (exec_bblock _ _ b2 _ _) as [rs3 m3|] eqn:EXEB2; auto. - - pose (trans_state_match (State rs1 m1)). - exploit forward_simu. - reflexivity. - eapply EXEB. - eapply m. - intros (s2' & EXEB' & MS). - exploit forward_simu. - reflexivity. - eapply EXEB2. - eapply m. - intros (s3' & EXEB'2 & MS2). inv H. - rewrite H0 in EXEB'. rewrite EXEB'2 in EXEB'. inv EXEB'. - exploit (state_equiv (State rs2 m2) (State rs3 m3) s2'). eauto. - congruence. - - rewrite trans_equiv_stuck in EXEB2. 2: eapply bblock_equiv'_comm; eauto. unfold exec in EXEB2. rewrite EXEB2 in EXEB. discriminate. - - rewrite trans_equiv_stuck in EXEB; eauto. unfold exec in EXEB. rewrite EXEB in EXEB2. discriminate. -Qed. - - - (* Lemmas necessary for defining concat_all *) Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. Proof. @@ -257,7 +209,7 @@ Qed. Definition verify_schedule (bb bb' : bblock) : res unit := - match (bblock_equivb' (trans_block bb) (trans_block bb')) with + match (bblock_equivb bb bb') with | true => OK tt | false => Error (msg "PostpassScheduling.verify_schedule") end. @@ -276,7 +228,8 @@ Lemma verify_schedule_no_header: forall bb bb', verify_schedule (no_header bb) bb' = verify_schedule bb bb'. Proof. - intros. unfold verify_schedule. rewrite trans_block_noheader_inv. reflexivity. + intros. unfold verify_schedule. unfold bblock_equivb. unfold pure_bblock_eq_test. unfold bblock_eq_test. rewrite trans_block_noheader_inv. + reflexivity. Qed. @@ -285,7 +238,8 @@ Lemma stick_header_verify_schedule: stick_header hd bb' = hbb' -> verify_schedule bb bb' = verify_schedule bb hbb'. Proof. - intros. unfold verify_schedule. rewrite <- H. rewrite trans_block_header_inv. reflexivity. + intros. unfold verify_schedule. unfold bblock_equivb. unfold pure_bblock_eq_test. unfold bblock_eq_test. + rewrite <- H. rewrite trans_block_header_inv. reflexivity. Qed. Lemma check_size_stick_header: @@ -468,8 +422,8 @@ Proof. intros (tbb & CONC & STH). exists tbb. split; auto. rewrite verify_schedule_no_header in EQ0. erewrite stick_header_verify_schedule in EQ0; eauto. - apply trans_exec. apply bblock_equiv'_eq. unfold verify_schedule in EQ0. unfold bblock_equivb' in EQ0. - destruct (bblock_equivb _ _); auto; try discriminate. + eapply bblock_equiv_eq; eauto. unfold verify_schedule in EQ0. unfold bblock_equivb in EQ0. + destruct (pure_bblock_eq_test true _ _); auto; try discriminate. Qed. Theorem verified_schedule_correct: -- cgit From f8ae73357fd7650bc2409b9eddb5816d4025747e Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 5 Mar 2019 12:27:33 +0100 Subject: compilation of ImpIOOracles --- mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 11 ++++++++--- mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli | 1 - 2 files changed, 8 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml index e5ec8e87..0e5cf434 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -6,8 +6,10 @@ These oracles assumes the following extraction directives: *) open ImpPrelude +(* open BinNums open Datatypes +*) (* two auxiliary functions, for efficient mapping of "int" to "BinNums.positive" *) exception Overflow @@ -52,12 +54,13 @@ let memo_int2pos: int -> int -> BinNums.positive pi in find;; - +(* let string_coq2caml: char list -> string = fun l -> let buf = Buffer.create (List.length l) in List.iter (fun c -> Buffer.add_char buf c) l; Buffer.contents buf;; +*) let new_exit_observer: (unit -> unit) -> (unit -> unit) ref = fun f -> @@ -120,16 +123,18 @@ let zTr: BinNums.coq_Z -> int let ten = BinNums.Zpos (BinNums.Coq_xO (BinNums.Coq_xI (BinNums.Coq_xO BinNums.Coq_xH))) let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring -= let (q,r) = BinIntDef.Z.pos_div_eucl p ten in += let (q,r) = BinInt.Z.pos_div_eucl p ten in let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in match q with | BinNums.Z0 -> acc0 | BinNums.Zpos p0 -> string_of_pos p0 acc0 | _ -> assert false +(* let string_of_Z_debug: BinNums.coq_Z -> pstring = fun p -> CamlStr (string_of_int (zTr p)) - +*) + let string_of_Z: BinNums.coq_Z -> pstring = function | BinNums.Z0 -> CamlStr "0" diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli index 29db881b..6064286a 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli @@ -1,5 +1,4 @@ open ImpPrelude -open Datatypes (* -- cgit From 49938c96f41e8891aebcecf76b98f3363ce55fd5 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 5 Mar 2019 14:18:17 +0100 Subject: fix extraction of ImpConfig --- mppa_k1c/abstractbb/Impure/ImpConfig.v | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index 3d807c4e..1bd93d4c 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -19,15 +19,18 @@ Module Type ImpureView. *) -(* *) +(* START COMMENT *) Module UnsafeImpure. Parameter unsafe_coerce: forall {A}, t A -> A. Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. + Extraction Inline unsafe_coerce. + End UnsafeImpure. -(* *) +(* END COMMENT *) + End ImpureView. -- cgit From e55222aa300b7187a6c0e6d7796165cc1ed2161d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 5 Mar 2019 16:38:55 +0100 Subject: Added pretty printers --- mppa_k1c/Asmblockdeps.v | 227 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 208 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 63ccdeac..6bcf9816 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1342,25 +1342,214 @@ Proof. destruct MO as (? & ? & ?). discriminate. Qed. -Definition string_of_name (x: P.R.t): ?? pstring := RET (Str ("resname")). -(* match x with - | xH => RET (Str ("the_mem")) - | _ as x => - DO s <~ string_of_Z (Zpos (Pos.pred x)) ;; - RET ("R" +; s) - end. *) - -Definition string_of_op (op: P.op): ?? pstring := RET (Str ("OP")). -(* match op with - | P.Imm i => - DO s <~ string_of_Z i ;; - RET s - | P.ARITH ADD => RET (Str "ADD") - | P.ARITH SUB => RET (Str "SUB") - | P.ARITH MUL => RET (Str "MUL") - | P.LOAD => RET (Str "LOAD") - | P.STORE => RET (Str "STORE") - end. *) +Definition gpreg_name (gpr: gpreg) := + match gpr with + | GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4") + | GPR5 => Str ("GPR5") | GPR6 => Str ("GPR6") | GPR7 => Str ("GPR7") | GPR8 => Str ("GPR8") | GPR9 => Str ("GPR9") + | GPR10 => Str ("GPR10") | GPR11 => Str ("GPR11") | GPR12 => Str ("GPR12") | GPR13 => Str ("GPR13") | GPR14 => Str ("GPR14") + | GPR15 => Str ("GPR15") | GPR16 => Str ("GPR16") | GPR17 => Str ("GPR17") | GPR18 => Str ("GPR18") | GPR19 => Str ("GPR19") + | GPR20 => Str ("GPR20") | GPR21 => Str ("GPR21") | GPR22 => Str ("GPR22") | GPR23 => Str ("GPR23") | GPR24 => Str ("GPR24") + | GPR25 => Str ("GPR25") | GPR26 => Str ("GPR26") | GPR27 => Str ("GPR27") | GPR28 => Str ("GPR28") | GPR29 => Str ("GPR29") + | GPR30 => Str ("GPR30") | GPR31 => Str ("GPR31") | GPR32 => Str ("GPR32") | GPR33 => Str ("GPR33") | GPR34 => Str ("GPR34") + | GPR35 => Str ("GPR35") | GPR36 => Str ("GPR36") | GPR37 => Str ("GPR37") | GPR38 => Str ("GPR38") | GPR39 => Str ("GPR39") + | GPR40 => Str ("GPR40") | GPR41 => Str ("GPR41") | GPR42 => Str ("GPR42") | GPR43 => Str ("GPR43") | GPR44 => Str ("GPR44") + | GPR45 => Str ("GPR45") | GPR46 => Str ("GPR46") | GPR47 => Str ("GPR47") | GPR48 => Str ("GPR48") | GPR49 => Str ("GPR49") + | GPR50 => Str ("GPR50") | GPR51 => Str ("GPR51") | GPR52 => Str ("GPR52") | GPR53 => Str ("GPR53") | GPR54 => Str ("GPR54") + | GPR55 => Str ("GPR55") | GPR56 => Str ("GPR56") | GPR57 => Str ("GPR57") | GPR58 => Str ("GPR58") | GPR59 => Str ("GPR59") + | GPR60 => Str ("GPR60") | GPR61 => Str ("GPR61") | GPR62 => Str ("GPR62") | GPR63 => Str ("GPR63") + end. + +Definition string_of_name (x: P.R.t): ?? pstring := + if (Pos.eqb x pmem) then + RET (Str "MEM") + else + match inv_ppos x with + | Some RA => RET (Str ("RA")) + | Some PC => RET (Str ("PC")) + | Some (IR gpr) => RET (gpreg_name gpr) + | _ => RET (Str ("UNDEFINED")) + end. + +Definition string_of_name_r (n: arith_name_r): pstring := + match n with + | Ploadsymbol _ _ => "Ploadsymbol" + end. + +Definition string_of_name_rr (n: arith_name_rr): pstring := + match n with + Pmv => "Pmv" + | Pnegw => "Pnegw" + | Pnegl => "Pnegl" + | Pcvtl2w => "Pcvtl2w" + | Psxwd => "Psxwd" + | Pzxwd => "Pzxwd" + | Pfabsd => "Pfabsd" + | Pfabsw => "Pfabsw" + | Pfnegd => "Pfnegd" + | Pfnegw => "Pfnegw" + | Pfnarrowdw => "Pfnarrowdw" + | Pfwidenlwd => "Pfwidenlwd" + | Pfloatwrnsz => "Pfloatwrnsz" + | Pfloatuwrnsz => "Pfloatuwrnsz" + | Pfloatudrnsz => "Pfloatudrnsz" + | Pfloatudrnsz_i32 => "Pfloatudrnsz_i32" + | Pfloatdrnsz => "Pfloatdrnsz" + | Pfloatdrnsz_i32 => "Pfloatdrnsz_i32" + | Pfixedwrzz => "Pfixedwrzz" + | Pfixeduwrzz => "Pfixeduwrzz" + | Pfixeddrzz => "Pfixeddrzz" + | Pfixedudrzz => "Pfixedudrzz" + | Pfixeddrzz_i32 => "Pfixeddrzz_i32" + | Pfixedudrzz_i32 => "Pfixedudrzz_i32" + end. + +Definition string_of_name_ri32 (n: arith_name_ri32): pstring := + match n with + | Pmake => "Pmake" + end. + +Definition string_of_name_ri64 (n: arith_name_ri64): pstring := + match n with + | Pmakel => "Pmakel" + end. + +Definition string_of_name_rf32 (n: arith_name_rf32): pstring := + match n with + | Pmakefs => "Pmakefs" + end. + +Definition string_of_name_rf64 (n: arith_name_rf64): pstring := + match n with + | Pmakef => "Pmakef" + end. + +Definition string_of_name_rrr (n: arith_name_rrr): pstring := + match n with + Pcompw _ => "Pcompw" + | Pcompl _ => "Pcompl" + | Pfcompw _ => "Pfcompw" + | Pfcompl _ => "Pfcompl" + | Paddw => "Paddw" + | Psubw => "Psubw" + | Pmulw => "Pmulw" + | Pandw => "Pandw" + | Porw => "Porw" + | Pxorw => "Pxorw" + | Psraw => "Psraw" + | Psrlw => "Psrlw" + | Psllw => "Psllw" + | Paddl => "Paddl" + | Psubl => "Psubl" + | Pandl => "Pandl" + | Porl => "Porl" + | Pxorl => "Pxorl" + | Pmull => "Pmull" + | Pslll => "Pslll" + | Psrll => "Psrll" + | Psral => "Psral" + | Pfaddd => "Pfaddd" + | Pfaddw => "Pfaddw" + | Pfsbfd => "Pfsbfd" + | Pfsbfw => "Pfsbfw" + | Pfmuld => "Pfmuld" + | Pfmulw => "Pfmulw" + end. + +Definition string_of_name_rri32 (n: arith_name_rri32): pstring := + match n with + Pcompiw _ => "Pcompiw" + | Paddiw => "Paddiw" + | Pandiw => "Pandiw" + | Poriw => "Poriw" + | Pxoriw => "Pxoriw" + | Psraiw => "Psraiw" + | Psrliw => "Psrliw" + | Pslliw => "Pslliw" + | Psllil => "Psllil" + | Psrlil => "Psrlil" + | Psrail => "Psrail" + end. + +Definition string_of_name_rri64 (n: arith_name_rri64): pstring := + match n with + Pcompil _ => "Pcompil" + | Paddil => "Paddil" + | Pandil => "Pandil" + | Poril => "Poril" + | Pxoril => "Pxoril" + end. + +Definition string_of_arith (op: arith_op): pstring := + match op with + | OArithR n => string_of_name_r n + | OArithRR n => string_of_name_rr n + | OArithRI32 n _ => string_of_name_ri32 n + | OArithRI64 n _ => string_of_name_ri64 n + | OArithRF32 n _ => string_of_name_rf32 n + | OArithRF64 n _ => string_of_name_rf64 n + | OArithRRR n => string_of_name_rrr n + | OArithRRI32 n _ => string_of_name_rri32 n + | OArithRRI64 n _ => string_of_name_rri64 n + end. + +Definition string_of_name_lrro (n: load_name_rro) : pstring := + match n with + Plb => "Plb" + | Plbu => "Plbu" + | Plh => "Plh" + | Plhu => "Plhu" + | Plw => "Plw" + | Plw_a => "Plw_a" + | Pld => "Pld" + | Pld_a => "Pld_a" + | Pfls => "Pfls" + | Pfld => "Pfld" + end. + +Definition string_of_load (op: load_op): pstring := + match op with + | OLoadRRO n _ => string_of_name_lrro n + end. + +Definition string_of_name_srro (n: store_name_rro) : pstring := + match n with + Psb => "Psb" + | Psh => "Psh" + | Psw => "Psw" + | Psw_a => "Psw_a" + | Psd => "Psd" + | Psd_a => "Psd_a" + | Pfss => "Pfss" + | Pfsd => "Pfsd" + end. + +Definition string_of_store (op: store_op) : pstring := + match op with + | OStoreRRO n _ => string_of_name_srro n + end. + +Definition string_of_control (op: control_op) : pstring := + match op with + | Oj_l _ => "Oj_l" + | Ocb _ _ => "Ocb" + | Ocbu _ _ => "Ocbu" + | OError => "OError" + | OIncremPC _ => "OIncremPC" + end. + +Definition string_of_op (op: P.op): ?? pstring := + match op with + | Arith op => RET (string_of_arith op) + | Load op => RET (string_of_load op) + | Store op => RET (string_of_store op) + | Control op => RET (string_of_control op) + | Allocframe _ _ => RET (Str "Allocframe") + | Allocframe2 _ _ => RET (Str "Allocframe2") + | Freeframe _ _ => RET (Str "Freeframe") + | Freeframe2 _ _ => RET (Str "Freeframe2") + | Constant _ => RET (Str "Constant") + | Fail => RET (Str "Fail") + end. Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := if verb then -- cgit From 1b5dec35abfaf0aec3cb6005c24f5c93b83e5f4c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 5 Mar 2019 18:03:16 +0100 Subject: quick fix of equalities issues --- mppa_k1c/Asmblockdeps.v | 7 ++++++- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 4 ++++ 2 files changed, 10 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6bcf9816..6743e198 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -477,7 +477,9 @@ Proof. Qed. -Definition op_eq (o1 o2: op): ?? bool := +Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. (* FIXME - quick hack: could be improved ? *) + +(* match o1, o2 with | Arith i1, Arith i2 => arith_op_eq i1 i2 | Load i1, Load i2 => load_op_eq i1 i2 @@ -490,11 +492,13 @@ Definition op_eq (o1 o2: op): ?? bool := | Fail, Fail => RET true | _, _ => RET false end. +*) Theorem op_eq_correct o1 o2: WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. +(* - simpl in Hexta. exploit arith_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. @@ -503,6 +507,7 @@ Proof. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - congruence. +*) Qed. End IMPPARAM. diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index cebc7a72..46f2d387 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -82,6 +82,10 @@ Export PhysEqModel. Extract Constant phys_eq => "(==)". Hint Resolve phys_eq_correct: wlp. +Axiom struct_eq: forall {A}, A -> A -> ?? bool. +Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN b=true -> x=y. +Extract Constant struct_eq => "(=)". +Hint Resolve struct_eq_correct: wlp. (** Data-structure for generic hash-consing *) -- cgit From 3def94ad1abfbf5f6445b08db0d908b9254f0b3b Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 6 Mar 2019 11:14:33 +0100 Subject: fix eq sur OIncremPC --- mppa_k1c/Asmblockdeps.v | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6743e198..aa1e7824 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -461,7 +461,7 @@ Definition control_op_eq (c1 c2: control_op): ?? bool := | Oj_l l1, Oj_l l2 => phys_eq l1 l2 | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) - | OIncremPC sz1, OIncremPC sz2 => phys_eq sz1 sz2 + | OIncremPC sz1, OIncremPC sz2 => RET (Z.eqb sz1 sz2) | OError, OError => RET true | _, _ => RET false end. @@ -473,13 +473,11 @@ Proof. - congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - - congruence. + - rewrite Z.eqb_eq in * |-. congruence. Qed. - -Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. (* FIXME - quick hack: could be improved ? *) - (* +Definition op_eq (o1 o2: op): ?? bool := match o1, o2 with | Arith i1, Arith i2 => arith_op_eq i1 i2 | Load i1, Load i2 => load_op_eq i1 i2 @@ -492,13 +490,12 @@ Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. (* FIXME - quick hack: | Fail, Fail => RET true | _, _ => RET false end. -*) + Theorem op_eq_correct o1 o2: WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. -(* - simpl in Hexta. exploit arith_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. @@ -507,7 +504,17 @@ Proof. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - congruence. +Qed. *) + +(* 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. -- cgit From 92b2b70c998c3a763a5c08343dc1c05254380322 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 6 Mar 2019 17:43:46 +0100 Subject: HACK for the Pcompw/Pcompl memory problem (but performance decrease, to remove later) --- mppa_k1c/PostpassSchedulingOracle.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index db50e3a5..7742b59d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -139,7 +139,10 @@ let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Re 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_rrr_rec i rd rs1 rs2 = (* FIXME - hack for memory problem with Pcompw and Pcompl, performance decreased *) + match i with + | Pcompw _ | Pcompl _ -> { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2; Mem]; imm = None; is_control = false} + | _ -> { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [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} -- cgit From 7ef1d2eafecfd428e25e3cbf37300ebf73a57c02 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 7 Mar 2019 09:59:25 +0100 Subject: Experiment Patch of Memory Model --- mppa_k1c/Asmblock.v | 39 ++++++++++++++++++++++++++++++--------- mppa_k1c/Asmblockdeps.v | 4 ++-- mppa_k1c/Asmblockgenproof1.v | 26 ++++++++++++++++---------- 3 files changed, 48 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 86c47613..3305bf95 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -902,8 +902,29 @@ Definition cmpu_for_btest (bt: btest) := | _ => (None, Int) end. +(* FIXME: move these axioms and definitions in a separate file (e.g. PatchMemoryModel). *) +Axiom Val_cmpu_bool: comparison -> val -> val -> option bool. + +Axiom Val_cmpu_bool_correct: forall (m:mem) (cmp: comparison) (v1 v2: val) b, + (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmpu_bool cmp v1 v2) = Some b. + +Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). + +Lemma Val_cmpu_correct: forall (m:mem) (cmp: comparison) (v1 v2: val), + Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) + (Val_cmpu cmp v1 v2). +Proof. + intros; unfold Val.cmpu, Val_cmpu. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob; simpl. + - erewrite Val_cmpu_bool_correct; eauto. + econstructor. + - econstructor. +Qed. + (** Comparing integers *) -Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := +Definition compare_int (t: itest) (v1 v2: val): val := match t with | ITne => Val.cmp Cne v1 v2 | ITeq => Val.cmp Ceq v1 v2 @@ -911,12 +932,12 @@ Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := | ITge => Val.cmp Cge v1 v2 | ITle => Val.cmp Cle v1 v2 | ITgt => Val.cmp Cgt v1 v2 - | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2 - | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 - | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2 - | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2 - | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2 - | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 + | ITneu => Val_cmpu Cne v1 v2 + | ITequ => Val_cmpu Ceq v1 v2 + | ITltu => Val_cmpu Clt v1 v2 + | ITgeu => Val_cmpu Cge v1 v2 + | ITleu => Val_cmpu Cle v1 v2 + | ITgtu => Val_cmpu Cgt v1 v2 | ITall | ITnall | ITany @@ -1038,7 +1059,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | PArithRRR n d s1 s2 => match n with - | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) + | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2) | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) | Pfcompw c => rs#d <- (compare_single c rs#s1 rs#s2) | Pfcompl c => rs#d <- (compare_float c rs#s1 rs#s2) @@ -1072,7 +1093,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | PArithRRI32 n d s i => match n with - | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i) m) + | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i)) | Paddiw => rs#d <- (Val.add rs#s (Vint i)) | Pandiw => rs#d <- (Val.and rs#s (Vint i)) | Poriw => rs#d <- (Val.or rs#s (Vint i)) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index aa1e7824..fa21d3b1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -153,7 +153,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRR n, [Val v1; Val v2; Memstate m] => match n with - | Pcompw c => Some (Val (compare_int c v1 v2 m)) + | Pcompw c => Some (Val (compare_int c v1 v2)) | Pcompl c => Some (Val (compare_long c v1 v2 m)) | _ => None end @@ -195,7 +195,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRI32 n i, [Val v; Memstate m] => match n with - | Pcompiw c => Some (Val (compare_int c v (Vint i) m)) + | Pcompiw c => Some (Val (compare_int c v (Vint i))) | _ => None end diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 76404257..e6e5d11e 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -355,10 +355,10 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. @@ -374,7 +374,7 @@ Lemma transl_compu_correct: exists rs', exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + /\ (Val_cmpu_bool (*Mem.valid_pointer m*) cmp rs#r1 rs#r2 = Some b -> exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -384,14 +384,15 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool. - destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + remember (Val_cmpu_bool (*Mem.valid_pointer m*) cmp rs#r1 rs#r2) as cmpubool. + destruct cmp; simpl; unfold Val_cmpu; + rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; destruct b0; simpl; auto. } rewrite H0. simpl; auto. @@ -607,6 +608,8 @@ Proof. destruct cmp; discriminate. Qed. +Local Hint Resolve Val_cmpu_bool_correct. + Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, transl_cbranch cond args lbl k = OK c -> @@ -635,7 +638,7 @@ Proof. exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. - + split; auto. apply C; auto. + + split; auto. apply C; eauto. (* Ccompimm *) - remember (Int.eq n Int.zero) as eqz. destruct eqz. @@ -810,11 +813,12 @@ Proof. split; intros; Simpl. Qed. + Lemma transl_cond_int32u_correct: forall cmp rd r1 r2 k rs m, exists rs', exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs#r1 rs#r2 + /\ rs'#rd = Val_cmpu cmp rs#r1 rs#r2 /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. @@ -899,6 +903,8 @@ Proof. split; intros; Simpl. Qed. +Local Hint Resolve Val_cmpu_correct. + Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, r1 <> RTMP -> @@ -1116,7 +1122,7 @@ Proof. exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto. + (* cmpu *) exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B; auto. + exists rs'; repeat split; eauto. rewrite B; eapply Val_cmpu_correct. + (* cmpimm *) apply transl_condimm_int32s_correct; eauto with asmgen. + (* cmpuimm *) -- cgit From 3564930d1bbcdc86f9e884b05ab986ac81cf2ab3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 7 Mar 2019 13:24:08 +0100 Subject: HACK for Pcompiw/Pcompil as well --- mppa_k1c/PostpassSchedulingOracle.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 7742b59d..b4b87031 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -135,9 +135,15 @@ let load_str = function 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_rri32_rec i rd rs imm32 = + match i with + | Pcompiw _ -> { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs; Mem]; imm = imm32; is_control = false } + | _ -> { 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_rri64_rec i rd rs imm64 = + match i with + | Pcompil _ -> { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs; Mem]; imm = imm64; is_control = false } + | _ -> { 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 = (* FIXME - hack for memory problem with Pcompw and Pcompl, performance decreased *) match i with -- cgit From a958e451457fb932248eb47ee44c833d57cfcdb7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 7 Mar 2019 14:45:31 +0100 Subject: Remplacement de phys_eq par Z.eqb pour Allocframe (1 & 2) et Freeframe (1 & 2) --- mppa_k1c/Asmblockdeps.v | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index aa1e7824..8e176f2d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -409,7 +409,7 @@ Definition iandb (ib1 ib2: ?? bool): ?? bool := Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o1, o2 with - | OArithR n1, OArithR n2 => phys_eq n1 n2 + | OArithR n1, OArithR n2 => struct_eq n1 n2 | OArithRR n1, OArithRR n2 => phys_eq n1 n2 | OArithRI32 n1 i1, OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | OArithRI64 n1 i1, OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) @@ -476,16 +476,17 @@ Proof. - rewrite Z.eqb_eq in * |-. congruence. Qed. -(* + Definition op_eq (o1 o2: op): ?? bool := match o1, o2 with | Arith i1, Arith i2 => arith_op_eq i1 i2 | Load i1, Load i2 => load_op_eq i1 i2 | Store i1, Store i2 => store_op_eq i1 i2 | Control i1, Control i2 => control_op_eq i1 i2 - | Allocframe sz1 pos1, Allocframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) - | Freeframe sz1 pos1, Freeframe sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) - | Freeframe2 sz1 pos1, Freeframe2 sz2 pos2 => iandb (phys_eq sz1 sz2) (phys_eq pos1 pos2) + | Allocframe sz1 pos1, Allocframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) + | Allocframe2 sz1 pos1, Allocframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) + | Freeframe sz1 pos1, Freeframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) + | Freeframe2 sz1 pos1, Freeframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | Constant c1, Constant c2 => phys_eq c1 c2 | Fail, Fail => RET true | _, _ => RET false @@ -500,22 +501,25 @@ Proof. - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. - simpl in Hexta. exploit control_op_eq_correct. eassumption. eauto. congruence. - - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. + - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. + - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. + - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. - congruence. Qed. -*) + (* QUICK FIX WITH struct_eq *) -Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. +(* 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. -- cgit From b4fd9f9612629c04ddbe492425c679a50bbf3365 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 7 Mar 2019 15:48:16 +0100 Subject: remove dep of exec_arith_instr on memory. TODO: - prove admitted lemma in Asmblockdeps. - remove axioms in Asmblock if possible. --- mppa_k1c/Asmblock.v | 64 +++++++++++++++++++++++++++++++------------- mppa_k1c/Asmblockdeps.v | 25 ++++++----------- mppa_k1c/Asmblockgenproof1.v | 54 ++++++++++++++++--------------------- 3 files changed, 77 insertions(+), 66 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3305bf95..0d6c2e79 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -902,20 +902,29 @@ Definition cmpu_for_btest (bt: btest) := | _ => (None, Int) end. -(* FIXME: move these axioms and definitions in a separate file (e.g. PatchMemoryModel). *) -Axiom Val_cmpu_bool: comparison -> val -> val -> option bool. +(* FIXME: put this stuff related to the memory model in a distinct module *) +(* FIXME: currently, only deal with the special case with Archi.ptr64 = true *) +Definition Val_cmpu_bool c v1 v2: option bool := + match v1, v2 with + | Vint n1, Vint n2 => Some (Int.cmpu c n1 n2) + | _, _ => None + end. -Axiom Val_cmpu_bool_correct: forall (m:mem) (cmp: comparison) (v1 v2: val) b, +Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b -> (Val_cmpu_bool cmp v1 v2) = Some b. +Proof. + unfold Val.cmpu_bool, Val_cmpu_bool. + destruct v1, v2; try congruence; vm_compute; try congruence. +Qed. Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). -Lemma Val_cmpu_correct: forall (m:mem) (cmp: comparison) (v1 v2: val), +Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) (Val_cmpu cmp v1 v2). Proof. - intros; unfold Val.cmpu, Val_cmpu. + unfold Val.cmpu, Val_cmpu. remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. destruct ob; simpl. - erewrite Val_cmpu_bool_correct; eauto. @@ -923,6 +932,27 @@ Proof. - econstructor. Qed. +Axiom Val_cmplu_bool: forall (cmp: comparison) (v1 v2: val), option bool. + +Axiom Val_cmplu_bool_correct: forall (m:mem) (cmp: comparison) (v1 v2: val) b, + (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmplu_bool cmp v1 v2) = Some b. + +Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). + +Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): + Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) + (Val_cmplu cmp v1 v2). +Proof. + unfold Val.cmplu, Val_cmplu. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob as [b|]; simpl. + - erewrite Val_cmplu_bool_correct; eauto. + simpl. econstructor. + - econstructor. +Qed. + + (** Comparing integers *) Definition compare_int (t: itest) (v1 v2: val): val := match t with @@ -944,7 +974,7 @@ Definition compare_int (t: itest) (v1 v2: val): val := | ITnone => Vundef end. -Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := +Definition compare_long (t: itest) (v1 v2: val): val := let res := match t with | ITne => Val.cmpl Cne v1 v2 | ITeq => Val.cmpl Ceq v1 v2 @@ -952,12 +982,12 @@ Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := | ITge => Val.cmpl Cge v1 v2 | ITle => Val.cmpl Cle v1 v2 | ITgt => Val.cmpl Cgt v1 v2 - | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 - | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 - | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2 - | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2 - | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2 - | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2 + | ITneu => Some (Val_cmplu Cne v1 v2) + | ITequ => Some (Val_cmplu Ceq v1 v2) + | ITltu => Some (Val_cmplu Clt v1 v2) + | ITgeu => Some (Val_cmplu Cge v1 v2) + | ITleu => Some (Val_cmplu Cle v1 v2) + | ITgtu => Some (Val_cmplu Cgt v1 v2) | ITall | ITnall | ITany @@ -995,14 +1025,12 @@ Definition compare_float (t: ftest) (v1 v2: val): val := TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... -FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.valid_pointer m)" - *) Variable ge: genv. -Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset := +Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := match ai with | PArithR n d => match n with @@ -1060,7 +1088,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | PArithRRR n d s1 s2 => match n with | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2) - | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) + | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2) | Pfcompw c => rs#d <- (compare_single c rs#s1 rs#s2) | Pfcompl c => rs#d <- (compare_float c rs#s1 rs#s2) | Paddw => rs#d <- (Val.add rs#s1 rs#s2) @@ -1108,7 +1136,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset | PArithRRI64 n d s i => match n with - | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m) + | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i)) | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) | Poril => rs#d <- (Val.orl rs#s (Vlong i)) @@ -1156,7 +1184,7 @@ Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset := match bi with - | PArith ai => Next (exec_arith_instr ai rs m) m + | PArith ai => Next (exec_arith_instr ai rs) m | PLoadRRO n d a ofs => match n with diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index fa21d3b1..fc012557 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -154,7 +154,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRR n, [Val v1; Val v2; Memstate m] => match n with | Pcompw c => Some (Val (compare_int c v1 v2)) - | Pcompl c => Some (Val (compare_long c v1 v2 m)) + | Pcompl c => Some (Val (compare_long c v1 v2)) | _ => None end @@ -193,14 +193,9 @@ Definition arith_eval (ao: arith_op) (l: list value) := | _ => None end - | OArithRRI32 n i, [Val v; Memstate m] => - match n with - | Pcompiw c => Some (Val (compare_int c v (Vint i))) - | _ => None - end - | OArithRRI32 n i, [Val v] => match n with + | Pcompiw c => Some (Val (compare_int c v (Vint i))) | Paddiw => Some (Val (Val.add v (Vint i))) | Pandiw => Some (Val (Val.and v (Vint i))) | Poriw => Some (Val (Val.or v (Vint i))) @@ -211,22 +206,15 @@ Definition arith_eval (ao: arith_op) (l: list value) := | Psllil => Some (Val (Val.shll v (Vint i))) | Psrlil => Some (Val (Val.shrlu v (Vint i))) | Psrail => Some (Val (Val.shrl v (Vint i))) - | _ => None - end - - | OArithRRI64 n i, [Val v; Memstate m] => - match n with - | Pcompil c => Some (Val (compare_long c v (Vlong i) m)) - | _ => None end | OArithRRI64 n i, [Val v] => match n with + | Pcompil c => Some (Val (compare_long c v (Vlong i))) | Paddil => Some (Val (Val.addl v (Vlong i))) | Pandil => Some (Val (Val.andl v (Vlong i))) | Poril => Some (Val (Val.orl v (Vlong i))) | Pxoril => Some (Val (Val.xorl v (Vlong i))) - | _ => None end | _, _ => None @@ -796,7 +784,7 @@ Qed. Lemma trans_arith_correct: forall ge fn i rs m rs' s, - exec_arith_instr ge i rs m = rs' -> + exec_arith_instr ge i rs = rs' -> match_states (State rs m) s -> exists s', macro_run (Genv ge fn) (trans_arith i) s s = Some s' @@ -851,9 +839,11 @@ Proof. destruct (ireg_eq g rd); subst; Simpl ]. (* PArithRRI32 *) - destruct i. +Admitted. +(* FIXME: A FINIR all: inv H; inv H0; eexists; split; try split; - [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); reflexivity + [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); auto | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. @@ -866,6 +856,7 @@ Proof. | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. Qed. +*) Lemma forward_simu_basic: forall ge fn b rs m rs' m' s, diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e6e5d11e..d9ce95ab 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -374,7 +374,7 @@ Lemma transl_compu_correct: exists rs', exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (Val_cmpu_bool (*Mem.valid_pointer m*) cmp rs#r1 rs#r2 = Some b -> + /\ (Val_cmpu_bool cmp rs#r1 rs#r2 = Some b -> exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -390,7 +390,7 @@ Proof. assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val_cmpu_bool (*Mem.valid_pointer m*) cmp rs#r1 rs#r2) as cmpubool. + remember (Val_cmpu_bool cmp rs#r1 rs#r2) as cmpubool. destruct cmp; simpl; unfold Val_cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; destruct b0; simpl; auto. @@ -413,16 +413,16 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; - unfold compare_long; - unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + unfold compare_long, Val.cmpl; + rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. } rewrite H0. simpl; auto. @@ -433,7 +433,7 @@ Lemma transl_complu_correct: exists rs', exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + /\ ( Val_cmplu_bool cmp rs#r1 rs#r2 = Some b -> exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -443,16 +443,15 @@ Proof. - split. + intros; Simpl. + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool. + remember (Val_cmplu_bool cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; - unfold compare_long; - unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. } rewrite H0. simpl; auto. @@ -608,7 +607,7 @@ Proof. destruct cmp; discriminate. Qed. -Local Hint Resolve Val_cmpu_bool_correct. +Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, @@ -701,7 +700,7 @@ Proof. exists rs', (Pcb BTwnez RTMP lbl). split. + constructor. eexact A. - + split; auto. apply C; auto. + + split; auto. apply C; eauto. (* Ccomplimm *) - remember (Int64.eq n Int64.zero) as eqz. destruct eqz. @@ -862,12 +861,12 @@ Lemma transl_cond_int64u_correct: forall cmp rd r1 r2 k rs m, exists rs', exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 rs#r2) + /\ rs'#rd = Val_cmplu cmp rs#r1 rs#r2 /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. + split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. - econstructor; split. apply exec_straight_one; [simpl; eauto]. @@ -903,7 +902,7 @@ Proof. split; intros; Simpl. Qed. -Local Hint Resolve Val_cmpu_correct. +Local Hint Resolve Val_cmpu_correct Val_cmplu_correct. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, @@ -959,19 +958,10 @@ Lemma transl_condimm_int64u_correct: /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. + intros. destruct cmp; simpl; + (econstructor; split; + [ apply exec_straight_one; [simpl; eauto] | + split; intros; Simpl; unfold compare_long; eauto]). Qed. Lemma swap_comparison_cmpfs: @@ -1000,7 +990,8 @@ Proof. split; intros; Simpl. apply swap_comparison_cmpfs. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. apply swap_comparison_cmpfs. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. +- econstructor; split. apply exec_straight_one; [simpl; + eauto]. split; intros; Simpl. Qed. @@ -1133,6 +1124,7 @@ Proof. + (* cmplu *) exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. + eapply Val_cmplu_correct. + (* cmplimm *) exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). -- cgit From d4e023d87ec851ca3b670b45327c95600f4afee4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 7 Mar 2019 16:26:28 +0100 Subject: Fix minor proof --- mppa_k1c/Asmblockgen.v | 62 ++++++++++++++++++------------ mppa_k1c/Asmblockgenproof.v | 16 +++++++- mppa_k1c/Asmblockgenproof1.v | 91 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 142 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index edffd879..8c6457a6 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -190,14 +190,29 @@ Definition transl_opt_compluimm loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) . -(* match select_compl n c with - | Some Ceq => Pcbu BTdeqz r1 lbl ::g k - | Some Cne => Pcbu BTdnez r1 lbl ::g k - | Some _ => nil (* Never happens *) - | None => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) - end - . - *) +Definition transl_comp_float32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_notfloat32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_float64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_notfloat64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := @@ -234,23 +249,19 @@ Definition transl_cbranch else loadimm64 RTMP n ::g (transl_compl c Signed r1 RTMP lbl k) ) -(*| Ccompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompf c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_float c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) - | Ccompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) - | Cnotcompfs c, f1 :: f2 :: nil => - do r1 <- freg_of f1; do r2 <- freg_of f2; - let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) -*)| _, _ => + | Ccompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_float64 c r1 r2 lbl k) + | Cnotcompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_notfloat64 c r1 r2 lbl k) + | Ccompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_float32 c r1 r2 lbl k) + | Cnotcompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_notfloat32 c r1 r2 lbl k) + | _, _ => Error(msg "Asmgenblock.transl_cbranch") end. @@ -282,6 +293,7 @@ Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + Definition transl_cond_float32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := match ftest_for_cmp cmp with | Normal ft => Pfcompw ft rd r1 r2 ::i k diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1ac9a211..84877488 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -891,6 +891,10 @@ Proof. + 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. + simpl in TIC. inv TIC. + simpl in TIC. monadInv TIC. simpl. eauto. - monadInv TIC. simpl; auto. @@ -990,6 +994,10 @@ Proof. + 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. @@ -1005,8 +1013,12 @@ Proof. - 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_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: diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 76404257..b3519064 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -427,6 +427,69 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compf_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_float64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpf_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. Admitted. +(* intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. *) + +Lemma transl_compnotf_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_notfloat64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. Admitted. + +Lemma transl_compfs_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_float32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpfs_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. Admitted. + +Lemma transl_compnotfs_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_notfloat32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. Admitted. + Lemma transl_complu_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', @@ -751,6 +814,34 @@ Proof. * split; auto. { apply C'; auto. rewrite B, C; eauto with asmgen. } { intros. rewrite B'; eauto with asmgen. } + +(* Ccompf *) +- exploit (transl_compf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Cnotcompf *) +- exploit (transl_compnotf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Ccompfs *) +- exploit (transl_compfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Cnotcompfs *) +- exploit (transl_compnotfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. Qed. Lemma transl_cbranch_correct_true: -- cgit From 8e48a27586656c62bbd7917564d213319870832e Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 7 Mar 2019 16:38:15 +0100 Subject: axioms on pointer comparison removed ! --- mppa_k1c/Asmblock.v | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 0d6c2e79..39b1c45c 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -902,20 +902,17 @@ Definition cmpu_for_btest (bt: btest) := | _ => (None, Int) end. -(* FIXME: put this stuff related to the memory model in a distinct module *) -(* FIXME: currently, only deal with the special case with Archi.ptr64 = true *) -Definition Val_cmpu_bool c v1 v2: option bool := - match v1, v2 with - | Vint n1, Vint n2 => Some (Int.cmpu c n1 n2) - | _, _ => None - end. + +(* a few lemma on comparisons of unsigned (e.g. pointers) *) + +Definition Val_cmpu_bool cmp v1 v2: option bool := + Val.cmpu_bool (fun _ _ => true) cmp v1 v2. Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b -> (Val_cmpu_bool cmp v1 v2) = Some b. Proof. - unfold Val.cmpu_bool, Val_cmpu_bool. - destruct v1, v2; try congruence; vm_compute; try congruence. + intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). Qed. Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). @@ -932,11 +929,15 @@ Proof. - econstructor. Qed. -Axiom Val_cmplu_bool: forall (cmp: comparison) (v1 v2: val), option bool. +Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) + := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). -Axiom Val_cmplu_bool_correct: forall (m:mem) (cmp: comparison) (v1 v2: val) b, +Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b -> (Val_cmplu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). +Qed. Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). -- cgit From 4ec4ce3c17c0aceadc34d0d203b0f01f0fbabfa1 Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 7 Mar 2019 17:32:24 +0100 Subject: Machblockgen proofs --- mppa_k1c/Machblockgen.v | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v index fb63c78c..4dfc309e 100644 --- a/mppa_k1c/Machblockgen.v +++ b/mppa_k1c/Machblockgen.v @@ -175,8 +175,8 @@ Proof. + (* case Tr_end_block *) inversion H3; subst; simpl; auto. * destruct (header bh); congruence. * destruct bl0; simpl; congruence. - + (* case Tr_add_basic *) -Admitted. (* A FINIR *) + + (* case Tr_add_basic *) rewrite H3. simpl. destruct (header bh); congruence. +Qed. Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, is_trans_code (rev_append c1 c2) mbi -> @@ -186,11 +186,22 @@ Proof. intros; exploit IHc1; eauto. intros (mbi0 & H1 & H2); subst. exploit add_to_code_is_trans_code_inv; eauto. -Admitted. (* A FINIR *) + intros. destruct H0 as [mbi1 [H2 H3]]. + exists mbi1. split; congruence. +Qed. Local Hint Resolve trans_code_is_trans_code. Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). Proof. constructor; intros; subst; auto. -Admitted. (* A FINIR *) + unfold trans_code. + exploit (trans_code_is_trans_code_rev_inv (rev_append c nil) nil bl); eauto. + * rewrite <- rev_alt. + rewrite <- rev_alt. + rewrite (rev_involutive c). + apply H. + * intros. + destruct H0 as [mbi [H0 H1]]. + inversion H0. subst. reflexivity. +Qed. -- cgit From 8e68be1345bef8e2f8ee428c51d4290e4464ebd6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 7 Mar 2019 18:25:30 +0100 Subject: Preuves du branchement avec des float --- mppa_k1c/Asmblockgenproof1.v | 267 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 242 insertions(+), 25 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index b3519064..060f1a85 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -222,8 +222,6 @@ Qed. *) *) -Definition yolo := 4. - Lemma opimm64_correct: forall (op: arith_name_rrr) (opi: arith_name_rri64) @@ -427,6 +425,22 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma swap_comparison_cmpf_eq: + forall v1 v2 cmp, + (Val.cmpf cmp v1 v2) = (Val.cmpf (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. + rewrite Float.cmp_swap. auto. +Qed. + +Lemma swap_comparison_cmpf_bool: + forall cmp ft v1 v2, + ftest_for_cmp cmp = Reversed ft -> + Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. +Qed. + Lemma transl_compf_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', @@ -436,26 +450,80 @@ Lemma transl_compf_correct: exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . -Proof. Admitted. -(* intros. esplit. split. -- unfold transl_compl. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold compare_long; - unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. *) +Proof. + intros. unfold transl_comp_float64. destruct (ftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpf_bool in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma cmpf_bool_ne_eq: + forall v1 v2, + Val.cmpf_bool Cne v1 v2 = option_map negb (Val.cmpf_bool Ceq v1 v2). +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. reflexivity. +Qed. + +Lemma cmpf_bool_ne_eq_rev: + forall v1 v2, + Val.cmpf_bool Ceq v1 v2 = option_map negb (Val.cmpf_bool Cne v1 v2). +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. +Qed. + +Lemma option_map_negb_negb: + forall v, + option_map negb (option_map negb v) = v. +Proof. + destruct v; simpl; auto. rewrite negb_involutive. reflexivity. +Qed. + +Lemma notbool_option_map_negb: + forall v, Val.notbool (Val.of_optbool v) = Val.of_optbool (option_map negb v). +Proof. + unfold Val.notbool. unfold Val.of_optbool. + destruct v; auto. destruct b; auto. +Qed. + +Lemma swap_comparison_cmpf_bool_notftest: + forall cmp ft v1 v2, + notftest_for_cmp cmp = Reversed ft -> + Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. +Qed. Lemma transl_compnotf_correct: forall cmp r1 r2 lbl k rs m tbb b, @@ -466,7 +534,56 @@ Lemma transl_compnotf_correct: exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . -Proof. Admitted. +Proof. + intros. unfold transl_comp_notfloat64. destruct (notftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2)) as cmpbool. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT. + * rewrite cmpf_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite cmpf_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpf_bool_notftest in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma swap_comparison_cmpfs_bool: + forall cmp ft v1 v2, + ftest_for_cmp cmp = Reversed ft -> + Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. +Qed. Lemma transl_compfs_correct: forall cmp r1 r2 lbl k rs m tbb b, @@ -477,7 +594,66 @@ Lemma transl_compfs_correct: exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . -Proof. Admitted. +Proof. + intros. unfold transl_comp_float32. destruct (ftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpfs_bool in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma swap_comparison_cmpfs_bool_notftest: + forall cmp ft v1 v2, + notftest_for_cmp cmp = Reversed ft -> + Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. +Qed. + +Lemma cmpfs_bool_ne_eq: + forall v1 v2, + Val.cmpfs_bool Cne v1 v2 = option_map negb (Val.cmpfs_bool Ceq v1 v2). +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. reflexivity. +Qed. + +Lemma cmpfs_bool_ne_eq_rev: + forall v1 v2, + Val.cmpfs_bool Ceq v1 v2 = option_map negb (Val.cmpfs_bool Cne v1 v2). +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. +Qed. Lemma transl_compnotfs_correct: forall cmp r1 r2 lbl k rs m tbb b, @@ -488,7 +664,48 @@ Lemma transl_compnotfs_correct: exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . -Proof. Admitted. +Proof. + intros. unfold transl_comp_notfloat32. destruct (notftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2)) as cmpbool. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT. + * rewrite cmpfs_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite cmpfs_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpfs_bool_notftest in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. Lemma transl_complu_correct: forall cmp r1 r2 lbl k rs m tbb b, -- cgit From 9b8348b2e3fcbb8394cec54d6fb4e9ac443b21fe Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 11:05:57 +0100 Subject: Refactorized Asmblock exec_basic_instr --- mppa_k1c/Asmblock.v | 224 ++++++++++++++++++++----------------- mppa_k1c/PostpassSchedulingproof.v | 2 +- 2 files changed, 121 insertions(+), 105 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 39b1c45c..f2ad60e6 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1030,119 +1030,135 @@ TODO: subsplitting by instruction type ? Could be useful for expressing auxiliar Variable ge: genv. +Definition arith_eval_r n := + match n with + | Ploadsymbol s ofs => Genv.symbol_address ge s ofs + end +. -Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := - match ai with - | PArithR n d => - match n with - | Ploadsymbol s ofs => rs#d <- (Genv.symbol_address ge s ofs) - end +Definition arith_eval_rr n v := + match n with + | Pmv => v + | Pnegw => Val.neg v + | Pnegl => Val.negl v + | Pcvtl2w => Val.loword v + | Psxwd => Val.longofint v + | Pzxwd => Val.longofintu v + | Pfnegd => Val.negf v + | Pfnegw => Val.negfs v + | Pfabsd => Val.absf v + | Pfabsw => Val.absfs v + | Pfnarrowdw => Val.singleoffloat v + | Pfwidenlwd => Val.floatofsingle v + | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end + | Pfloatuwrnsz => match Val.singleofintu v with Some f => f | _ => Vundef end + | Pfloatudrnsz => match Val.floatoflongu v with Some f => f | _ => Vundef end + | Pfloatdrnsz => match Val.floatoflong v with Some f => f | _ => Vundef end + | Pfloatudrnsz_i32 => match Val.floatofintu v with Some f => f | _ => Vundef end + | Pfloatdrnsz_i32 => match Val.floatofint v with Some f => f | _ => Vundef end + | Pfixedwrzz => match Val.intofsingle v with Some i => i | _ => Vundef end + | Pfixeduwrzz => match Val.intuofsingle v with Some i => i | _ => Vundef end + | Pfixeddrzz => match Val.longoffloat v with Some i => i | _ => Vundef end + | Pfixedudrzz => match Val.longuoffloat v with Some i => i | _ => Vundef end + | Pfixeddrzz_i32 => match Val.intoffloat v with Some i => i | _ => Vundef end + | Pfixedudrzz_i32 => match Val.intuoffloat v with Some i => i | _ => Vundef end + end. - | PArithRR n d s => - match n with - | Pmv => rs#d <- (rs#s) - | Pnegw => rs#d <- (Val.neg rs#s) - | Pnegl => rs#d <- (Val.negl rs#s) - | Pcvtl2w => rs#d <- (Val.loword rs#s) - | Psxwd => rs#d <- (Val.longofint rs#s) - | Pzxwd => rs#d <- (Val.longofintu rs#s) - | Pfnegd => rs#d <- (Val.negf rs#s) - | Pfnegw => rs#d <- (Val.negfs rs#s) - | Pfabsd => rs#d <- (Val.absf rs#s) - | Pfabsw => rs#d <- (Val.absfs rs#s) - | Pfnarrowdw => rs#d <- (Val.singleoffloat rs#s) - | Pfwidenlwd => rs#d <- (Val.floatofsingle rs#s) - | Pfloatwrnsz => rs#d <- (match Val.singleofint rs#s with Some f => f | _ => Vundef end) - | Pfloatuwrnsz => rs#d <- (match Val.singleofintu rs#s with Some f => f | _ => Vundef end) - | Pfloatudrnsz => rs#d <- (match Val.floatoflongu rs#s with Some f => f | _ => Vundef end) - | Pfloatudrnsz_i32 => rs#d <- (match Val.floatofintu rs#s with Some f => f | _ => Vundef end) - | Pfloatdrnsz => rs#d <- (match Val.floatoflong rs#s with Some f => f | _ => Vundef end) - | Pfloatdrnsz_i32 => rs#d <- (match Val.floatofint rs#s with Some f => f | _ => Vundef end) - | Pfixedwrzz => rs#d <- (match Val.intofsingle rs#s with Some i => i | _ => Vundef end) - | Pfixeduwrzz => rs#d <- (match Val.intuofsingle rs#s with Some i => i | _ => Vundef end) - | Pfixeddrzz => rs#d <- (match Val.longoffloat rs#s with Some i => i | _ => Vundef end) - | Pfixeddrzz_i32 => rs#d <- (match Val.intoffloat rs#s with Some i => i | _ => Vundef end) - | Pfixedudrzz => rs#d <- (match Val.longuoffloat rs#s with Some i => i | _ => Vundef end) - | Pfixedudrzz_i32 => rs#d <- (match Val.intuoffloat rs#s with Some i => i | _ => Vundef end) - end +Definition arith_eval_ri32 n i := + match n with + | Pmake => Vint i + end. - | PArithRI32 n d i => - match n with - | Pmake => rs#d <- (Vint i) - end +Definition arith_eval_ri64 n i := + match n with + | Pmakel => Vlong i + end. - | PArithRI64 n d i => - match n with - | Pmakel => rs#d <- (Vlong i) - end +Definition arith_eval_rf32 n i := + match n with + | Pmakefs => Vsingle i + end. - | PArithRF32 n d i => - match n with - | Pmakefs => rs#d <- (Vsingle i) - end +Definition arith_eval_rf64 n i := + match n with + | Pmakef => Vfloat i + end. - | PArithRF64 n d i => - match n with - | Pmakef => rs#d <- (Vfloat i) - end +Definition arith_eval_rrr n v1 v2 := + match n with + | Pcompw c => compare_int c v1 v2 + | Pcompl c => compare_long c v1 v2 + | Pfcompw c => compare_single c v1 v2 + | Pfcompl c => compare_float c v1 v2 + + | Paddw => Val.add v1 v2 + | Psubw => Val.sub v1 v2 + | Pmulw => Val.mul v1 v2 + | Pandw => Val.and v1 v2 + | Porw => Val.or v1 v2 + | Pxorw => Val.xor v1 v2 + | Psrlw => Val.shru v1 v2 + | Psraw => Val.shr v1 v2 + | Psllw => Val.shl v1 v2 + + | Paddl => Val.addl v1 v2 + | Psubl => Val.subl v1 v2 + | Pandl => Val.andl v1 v2 + | Porl => Val.orl v1 v2 + | Pxorl => Val.xorl v1 v2 + | Pmull => Val.mull v1 v2 + | Pslll => Val.shll v1 v2 + | Psrll => Val.shrlu v1 v2 + | Psral => Val.shrl v1 v2 + + | Pfaddd => Val.addf v1 v2 + | Pfaddw => Val.addfs v1 v2 + | Pfsbfd => Val.subf v1 v2 + | Pfsbfw => Val.subfs v1 v2 + | Pfmuld => Val.mulf v1 v2 + | Pfmulw => Val.mulfs v1 v2 + end. - | PArithRRR n d s1 s2 => - match n with - | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2) - | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2) - | Pfcompw c => rs#d <- (compare_single c rs#s1 rs#s2) - | Pfcompl c => rs#d <- (compare_float c rs#s1 rs#s2) - | Paddw => rs#d <- (Val.add rs#s1 rs#s2) - | Psubw => rs#d <- (Val.sub rs#s1 rs#s2) - | Pmulw => rs#d <- (Val.mul rs#s1 rs#s2) - | Pandw => rs#d <- (Val.and rs#s1 rs#s2) - | Porw => rs#d <- (Val.or rs#s1 rs#s2) - | Pxorw => rs#d <- (Val.xor rs#s1 rs#s2) - | Psrlw => rs#d <- (Val.shru rs#s1 rs#s2) - | Psraw => rs#d <- (Val.shr rs#s1 rs#s2) - | Psllw => rs#d <- (Val.shl rs#s1 rs#s2) - - | Paddl => rs#d <- (Val.addl rs#s1 rs#s2) - | Psubl => rs#d <- (Val.subl rs#s1 rs#s2) - | Pandl => rs#d <- (Val.andl rs#s1 rs#s2) - | Porl => rs#d <- (Val.orl rs#s1 rs#s2) - | Pxorl => rs#d <- (Val.xorl rs#s1 rs#s2) - | Pmull => rs#d <- (Val.mull rs#s1 rs#s2) - | Pslll => rs#d <- (Val.shll rs#s1 rs#s2) - | Psrll => rs#d <- (Val.shrlu rs#s1 rs#s2) - | Psral => rs#d <- (Val.shrl rs#s1 rs#s2) - - | Pfaddd => rs#d <- (Val.addf rs#s1 rs#s2) - | Pfaddw => rs#d <- (Val.addfs rs#s1 rs#s2) - | Pfsbfd => rs#d <- (Val.subf rs#s1 rs#s2) - | Pfsbfw => rs#d <- (Val.subfs rs#s1 rs#s2) - | Pfmuld => rs#d <- (Val.mulf rs#s1 rs#s2) - | Pfmulw => rs#d <- (Val.mulfs rs#s1 rs#s2) - 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) + | Pandiw => Val.and v (Vint i) + | Poriw => Val.or v (Vint i) + | Pxoriw => Val.xor v (Vint i) + | Psraiw => Val.shr v (Vint i) + | Psrliw => Val.shru v (Vint i) + | Pslliw => Val.shl v (Vint i) + | Psllil => Val.shll v (Vint i) + | Psrlil => Val.shrlu v (Vint i) + | Psrail => Val.shrl v (Vint i) + end. - | PArithRRI32 n d s i => - match n with - | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i)) - | Paddiw => rs#d <- (Val.add rs#s (Vint i)) - | Pandiw => rs#d <- (Val.and rs#s (Vint i)) - | Poriw => rs#d <- (Val.or rs#s (Vint i)) - | Pxoriw => rs#d <- (Val.xor rs#s (Vint i)) - | Psraiw => rs#d <- (Val.shr rs#s (Vint i)) - | Psrliw => rs#d <- (Val.shru rs#s (Vint i)) - | Pslliw => rs#d <- (Val.shl rs#s (Vint i)) - | Psllil => rs#d <- (Val.shll rs#s (Vint i)) - | Psrlil => rs#d <- (Val.shrlu rs#s (Vint i)) - | Psrail => rs#d <- (Val.shrl rs#s (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) + | Pandil => Val.andl v (Vlong i) + | Poril => Val.orl v (Vlong i) + | Pxoril => Val.xorl v (Vlong i) + end. - | PArithRRI64 n d s i => - match n with - | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i)) - | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) - | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) - | Poril => rs#d <- (Val.orl rs#s (Vlong i)) - | Pxoril => rs#d <- (Val.xorl rs#s (Vlong i)) - end +Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := + match ai with + | PArithR n d => rs#d <- (arith_eval_r n) + + | PArithRR n d s => rs#d <- (arith_eval_rr n rs#s) + + | PArithRI32 n d i => rs#d <- (arith_eval_ri32 n i) + | PArithRI64 n d i => rs#d <- (arith_eval_ri64 n i) + | PArithRF32 n d i => rs#d <- (arith_eval_rf32 n i) + | PArithRF64 n d i => rs#d <- (arith_eval_rf64 n i) + + | PArithRRR n d s1 s2 => rs#d <- (arith_eval_rrr n rs#s1 rs#s2) + + | PArithRRI32 n d s i => rs#d <- (arith_eval_rri32 n rs#s i) + + | PArithRRI64 n d s i => rs#d <- (arith_eval_rri64 n rs#s i) end. (** * load/store *) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f969e5b4..8ad30e81 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -575,7 +575,7 @@ Lemma transf_exec_basic_instr: Proof. intros. pose symbol_address_preserved. unfold exec_basic_instr. exploreInst; simpl; auto; try congruence. - 1: unfold exec_arith_instr; exploreInst; simpl; auto; try congruence. + 1: unfold exec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. 1-10: apply transf_exec_load. all: apply transf_exec_store. Qed. -- cgit From 405f173c02e73a929ce9e9debb3f2bfa704702c7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 11:20:34 +0100 Subject: Fixing Asmblockdeps proofs --- mppa_k1c/Asmblockdeps.v | 168 ++++++------------------------------------------ 1 file changed, 21 insertions(+), 147 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index fc012557..ec5c3cf5 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -98,124 +98,19 @@ Definition op := op_wrap. Definition arith_eval (ao: arith_op) (l: list value) := let (ge, fn) := Ge in match ao, l with - | OArithR n, [] => - match n with - | Ploadsymbol s ofs => Some (Val (Genv.symbol_address ge s ofs)) - end + | OArithR n, [] => Some (Val (arith_eval_r ge n)) - | OArithRR n, [Val v] => - match n with - | Pmv => Some (Val v) - | Pnegw => Some (Val (Val.neg v)) - | Pnegl => Some (Val (Val.negl v)) - | Pcvtl2w => Some (Val (Val.loword v)) - | Psxwd => Some (Val (Val.longofint v)) - | Pzxwd => Some (Val (Val.longofintu v)) - | Pfnegd => Some (Val (Val.negf v)) - | Pfnegw => Some (Val (Val.negfs v)) - | Pfabsd => Some (Val (Val.absf v)) - | Pfabsw => Some (Val (Val.absfs v)) - | Pfnarrowdw => Some (Val (Val.singleoffloat v)) - | Pfwidenlwd => Some (Val (Val.floatofsingle v)) - | Pfloatwrnsz => Some (Val (match Val.singleofint v with Some f => f | _ => Vundef end)) - | Pfloatuwrnsz => Some (Val (match Val.singleofintu v with Some f => f | _ => Vundef end)) - | Pfloatudrnsz => Some (Val (match Val.floatoflongu v with Some f => f | _ => Vundef end)) - | Pfloatdrnsz => Some (Val (match Val.floatoflong v with Some f => f | _ => Vundef end)) - | Pfloatudrnsz_i32 => Some (Val (match Val.floatofintu v with Some f => f | _ => Vundef end)) - | Pfloatdrnsz_i32 => Some (Val (match Val.floatofint v with Some f => f | _ => Vundef end)) - | Pfixedwrzz => Some (Val (match Val.intofsingle v with Some i => i | _ => Vundef end)) - | Pfixeduwrzz => Some (Val (match Val.intuofsingle v with Some i => i | _ => Vundef end)) - | Pfixeddrzz => Some (Val (match Val.longoffloat v with Some i => i | _ => Vundef end)) - | Pfixedudrzz => Some (Val (match Val.longuoffloat v with Some i => i | _ => Vundef end)) - | Pfixeddrzz_i32 => Some (Val (match Val.intoffloat v with Some i => i | _ => Vundef end)) - | Pfixedudrzz_i32 => Some (Val (match Val.intuoffloat v with Some i => i | _ => Vundef end)) - end + | OArithRR n, [Val v] => Some (Val (arith_eval_rr n v)) - | OArithRI32 n i, [] => - match n with - | Pmake => Some (Val (Vint i)) - end + | OArithRI32 n i, [] => Some (Val (arith_eval_ri32 n i)) + | OArithRI64 n i, [] => Some (Val (arith_eval_ri64 n i)) + | OArithRF32 n i, [] => Some (Val (arith_eval_rf32 n i)) + | OArithRF64 n i, [] => Some (Val (arith_eval_rf64 n i)) - | OArithRI64 n i, [] => - match n with - | Pmakel => Some (Val (Vlong i)) - end + | OArithRRR n, [Val v1; Val v2] => Some (Val (arith_eval_rrr n v1 v2)) - | OArithRF32 n i, [] => - match n with - | Pmakefs => Some (Val (Vsingle i)) - end - - | OArithRF64 n i, [] => - match n with - | Pmakef => Some (Val (Vfloat i)) - end - - | OArithRRR n, [Val v1; Val v2; Memstate m] => - match n with - | Pcompw c => Some (Val (compare_int c v1 v2)) - | Pcompl c => Some (Val (compare_long c v1 v2)) - | _ => None - end - - | OArithRRR n, [Val v1; Val v2] => - match n with - | Pfcompw c => Some (Val (compare_single c v1 v2)) - | Pfcompl c => Some (Val (compare_float c v1 v2)) - - | Paddw => Some (Val (Val.add v1 v2)) - | Psubw => Some (Val (Val.sub v1 v2)) - | Pmulw => Some (Val (Val.mul v1 v2)) - | Pandw => Some (Val (Val.and v1 v2)) - | Porw => Some (Val (Val.or v1 v2)) - | Pxorw => Some (Val (Val.xor v1 v2)) - | Psrlw => Some (Val (Val.shru v1 v2)) - | Psraw => Some (Val (Val.shr v1 v2)) - | Psllw => Some (Val (Val.shl v1 v2)) - - | Paddl => Some (Val (Val.addl v1 v2)) - | Psubl => Some (Val (Val.subl v1 v2)) - | Pandl => Some (Val (Val.andl v1 v2)) - | Porl => Some (Val (Val.orl v1 v2)) - | Pxorl => Some (Val (Val.xorl v1 v2)) - | Pmull => Some (Val (Val.mull v1 v2)) - | Pslll => Some (Val (Val.shll v1 v2)) - | Psrll => Some (Val (Val.shrlu v1 v2)) - | Psral => Some (Val (Val.shrl v1 v2)) - - | Pfaddd => Some (Val (Val.addf v1 v2)) - | Pfaddw => Some (Val (Val.addfs v1 v2)) - | Pfsbfd => Some (Val (Val.subf v1 v2)) - | Pfsbfw => Some (Val (Val.subfs v1 v2)) - | Pfmuld => Some (Val (Val.mulf v1 v2)) - | Pfmulw => Some (Val (Val.mulfs v1 v2)) - - | _ => None - end - - | OArithRRI32 n i, [Val v] => - match n with - | Pcompiw c => Some (Val (compare_int c v (Vint i))) - | Paddiw => Some (Val (Val.add v (Vint i))) - | Pandiw => Some (Val (Val.and v (Vint i))) - | Poriw => Some (Val (Val.or v (Vint i))) - | Pxoriw => Some (Val (Val.xor v (Vint i))) - | Psraiw => Some (Val (Val.shr v (Vint i))) - | Psrliw => Some (Val (Val.shru v (Vint i))) - | Pslliw => Some (Val (Val.shl v (Vint i))) - | Psllil => Some (Val (Val.shll v (Vint i))) - | Psrlil => Some (Val (Val.shrlu v (Vint i))) - | Psrail => Some (Val (Val.shrl v (Vint i))) - end - - | OArithRRI64 n i, [Val v] => - match n with - | Pcompil c => Some (Val (compare_long c v (Vlong i))) - | Paddil => Some (Val (Val.addl v (Vlong i))) - | Pandil => Some (Val (Val.andl v (Vlong i))) - | Poril => Some (Val (Val.orl v (Vlong i))) - | Pxoril => Some (Val (Val.xorl v (Vlong i))) - end + | OArithRRI32 n i, [Val v] => Some (Val (arith_eval_rri32 n v i)) + | OArithRRI64 n i, [Val v] => Some (Val (arith_eval_rri64 n v i)) | _, _ => None end. @@ -605,21 +500,9 @@ Definition trans_arith (ai: ar_instruction) : macro := | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] - | PArithRRR n d s1 s2 => - match n with - | Pcompw _ | Pcompl _ => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Name pmem @ Enil))] - | _ => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] - end - | PArithRRI32 n d s i => - match n with - | Pcompiw _ => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Name pmem @ Enil))] - | _ => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] - end - | PArithRRI64 n d s i => - match n with - | Pcompil _ => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Name pmem @ Enil))] - | _ => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] - end + | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] + | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] + | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] end. @@ -792,71 +675,62 @@ Lemma trans_arith_correct: Proof. intros. unfold exec_arith_instr in H. destruct i. (* Ploadsymbol *) - - destruct i. inv H. inv H0. - eexists; split; try split. + - inv H; inv H0. eexists; split; try split. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRR *) - - destruct i. - all: inv H; inv H0; + - inv H; inv H0; eexists; split; try split; [ simpl; pose (H1 rs0); simpl in e; rewrite e; reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. (* PArithRI32 *) - - destruct i. inv H. inv H0. + - inv H. inv H0. eexists; split; try split. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRI64 *) - - destruct i. inv H. inv H0. + - inv H. inv H0. eexists; split; try split. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRF32 *) - - destruct i. inv H. inv H0. + - inv H. inv H0. eexists; split; try split. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRF64 *) - - destruct i. inv H. inv H0. + - inv H. inv H0. eexists; split; try split. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRRR *) - - destruct i. - all: inv H; inv H0; + - inv H; inv H0; eexists; split; try split; [ simpl; pose (H1 rs1); simpl in e; rewrite e; pose (H1 rs2); simpl in e0; rewrite e0; try (rewrite H); reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. (* PArithRRI32 *) - - destruct i. -Admitted. -(* FIXME: A FINIR - all: inv H; inv H0; + - inv H; inv H0; eexists; split; try split; [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); auto | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. -(* PArithRRI64 *) - - destruct i. - all: inv H; inv H0; + - inv H; inv H0; eexists; split; try split; [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. Qed. -*) Lemma forward_simu_basic: forall ge fn b rs m rs' m' s, -- cgit From baf349346968b79c37f9eeb71f11a3d42f86bf86 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 11:34:29 +0100 Subject: Reverting the hack introduces on Pcompw etc.. --- mppa_k1c/PostpassSchedulingOracle.ml | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b4b87031..89ec34e2 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -135,26 +135,15 @@ let load_str = function let set_str = "Pset" let get_str = "Pget" -let arith_rri32_rec i rd rs imm32 = - match i with - | Pcompiw _ -> { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs; Mem]; imm = imm32; is_control = false } - | _ -> { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false } +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 = - match i with - | Pcompil _ -> { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs; Mem]; imm = imm64; is_control = false } - | _ -> { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; 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 = (* FIXME - hack for memory problem with Pcompw and Pcompl, performance decreased *) - match i with - | Pcompw _ | Pcompl _ -> { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2; Mem]; imm = None; is_control = false} - | _ -> { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; 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_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_r_rec i rd = match i with - (* FIXME - this instruction is expanded to nothing, yet it still has a semantic in Asmblock.v. - * It will introduce unneeded dependencies.. *) (* 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} -- cgit From a57a83d632afb029c1e12c9851a8631ace7ded01 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 11:52:10 +0100 Subject: Refactorisation des load et des store --- mppa_k1c/Asmblock.v | 64 +++++++++++++++++++------------------- mppa_k1c/Asmblockdeps.v | 32 +++---------------- mppa_k1c/PostpassSchedulingproof.v | 6 ++-- 3 files changed, 40 insertions(+), 62 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index f2ad60e6..9938b386 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1022,11 +1022,7 @@ Definition compare_float (t: ftest) (v1 v2: val): val := | FTult => Val.notbool (Val.cmpf Cge v1 v2) end. -(** Execution of arith instructions - -TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... - -*) +(** Execution of arith instructions *) Variable ge: genv. @@ -1197,37 +1193,41 @@ Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) | _ => Stuck end. +Definition load_chunk n := + match n with + | Plb => Mint8signed + | Plbu => Mint8unsigned + | Plh => Mint16signed + | Plhu => Mint16unsigned + | Plw => Mint32 + | Plw_a => Many32 + | Pld => Mint64 + | Pld_a => Many64 + | Pfls => Mfloat32 + | Pfld => Mfloat64 + end. + +Definition store_chunk n := + match n with + | Psb => Mint8unsigned + | Psh => Mint16unsigned + | Psw => Mint32 + | Psw_a => Many32 + | Psd => Mint64 + | Psd_a => Many64 + | Pfss => Mfloat32 + | Pfsd => Mfloat64 + end. + (** * basic instructions *) Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset := - match bi with - | PArith ai => Next (exec_arith_instr ai rs) m - - | PLoadRRO n d a ofs => - match n with - | Plb => exec_load Mint8signed rs m d a ofs - | Plbu => exec_load Mint8unsigned rs m d a ofs - | Plh => exec_load Mint16signed rs m d a ofs - | Plhu => exec_load Mint16unsigned rs m d a ofs - | Plw => exec_load Mint32 rs m d a ofs - | Plw_a => exec_load Many32 rs m d a ofs - | Pld => exec_load Mint64 rs m d a ofs - | Pld_a => exec_load Many64 rs m d a ofs - | Pfls => exec_load Mfloat32 rs m d a ofs - | Pfld => exec_load Mfloat64 rs m d a ofs - end + match bi with + | PArith ai => Next (exec_arith_instr ai rs) m - | PStoreRRO n s a ofs => - match n with - | Psb => exec_store Mint8unsigned rs m s a ofs - | Psh => exec_store Mint16unsigned rs m s a ofs - | Psw => exec_store Mint32 rs m s a ofs - | Psw_a => exec_store Many32 rs m s a ofs - | Psd => exec_store Mint64 rs m s a ofs - | Psd_a => exec_store Many64 rs m s a ofs - | Pfss => exec_store Mfloat32 rs m s a ofs - | Pfsd => exec_store Mfloat64 rs m s a ofs - end + | PLoadRRO n d a ofs => exec_load (load_chunk n) rs m d a ofs + + | PStoreRRO n s a ofs => exec_store (store_chunk n) rs m s a ofs | Pallocframe sz pos => let (m1, stk) := Mem.alloc m 0 sz in diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b7e7b87c..14355d32 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -129,19 +129,7 @@ Definition exec_load_deps (chunk: memory_chunk) (m: mem) Definition load_eval (lo: load_op) (l: list value) := match lo, l with - | OLoadRRO n ofs, [Val v; Memstate m] => - match n with - | Plb => exec_load_deps Mint8signed m v ofs - | Plbu => exec_load_deps Mint8unsigned m v ofs - | Plh => exec_load_deps Mint16signed m v ofs - | Plhu => exec_load_deps Mint16unsigned m v ofs - | Plw => exec_load_deps Mint32 m v ofs - | Plw_a => exec_load_deps Many32 m v ofs - | Pld => exec_load_deps Mint64 m v ofs - | Pld_a => exec_load_deps Many64 m v ofs - | Pfls => exec_load_deps Mfloat32 m v ofs - | Pfld => exec_load_deps Mfloat64 m v ofs - end + | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps (load_chunk n) m v ofs | _, _ => None end. @@ -159,17 +147,7 @@ Definition exec_store_deps (chunk: memory_chunk) (m: mem) Definition store_eval (so: store_op) (l: list value) := match so, l with - | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => - match n with - | Psb => exec_store_deps Mint8unsigned m vs va ofs - | Psh => exec_store_deps Mint16unsigned m vs va ofs - | Psw => exec_store_deps Mint32 m vs va ofs - | Psw_a => exec_store_deps Many32 m vs va ofs - | Psd => exec_store_deps Mint64 m vs va ofs - | Psd_a => exec_store_deps Many64 m vs va ofs - | Pfss => exec_store_deps Mfloat32 m vs va ofs - | Pfsd => exec_store_deps Mfloat64 m vs va ofs - end + | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps (store_chunk n) m vs va ofs | _, _ => None end. @@ -748,8 +726,8 @@ Proof. (* Arith *) - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. (* Load *) - - simpl in H. destruct i; destruct i. - all: unfold exec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + - simpl in H. destruct i. + unfold exec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; eexists; split; try split; [ simpl; rewrite EVALOFF; rewrite H; pose (H1 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| @@ -759,7 +737,7 @@ Proof. subst; Simpl| Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. (* Store *) - - simpl in H. destruct i; destruct i. + - simpl in H. destruct i. all: unfold exec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; eexists; split; try split; diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 8ad30e81..2de49faa 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -575,9 +575,9 @@ Lemma transf_exec_basic_instr: Proof. intros. pose symbol_address_preserved. unfold exec_basic_instr. exploreInst; simpl; auto; try congruence. - 1: unfold exec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. - 1-10: apply transf_exec_load. - all: apply transf_exec_store. + - unfold exec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. + - apply transf_exec_load. + - apply transf_exec_store. Qed. Lemma transf_exec_body: -- cgit From fdc5df430f2823004d2506cf579f7126d46d3a26 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 14:31:02 +0100 Subject: Minor fix on TargetPrinter (coqint instead of coqint64 for adequate types) --- mppa_k1c/TargetPrinter.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5d59e7d2..70d9ff6c 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -415,21 +415,21 @@ module Target (*: TARGET*) = (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> - fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 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 coqint64 imm + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint imm | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> - fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psllil (rd, rs, imm) -> fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> -- cgit From 147c0ec814867d38edab86bbf1fd05e7fd23a68b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 15:15:59 +0100 Subject: Fix for the compw immediate problem --- mppa_k1c/PostpassSchedulingOracle.ml | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 89ec34e2..7b632144 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -249,14 +249,24 @@ let signed_length (i:int64) = in if (within i interv) then n else f i (n+1) in f i 1 +let unsigned_length (i:int64) = (signed_length i) - 1 + let encode_imm (imm:int64) = - let length = signed_length imm - in if length <= 7 then U6 (* Unsigned -> 1 bit less needed *) - else if length <= 10 then S10 - else if length <= 32 then U27L5 (* Upper 27 Lower 5 is signed *) - else if length <= 37 then U27L10 - else if length <= 64 then E27U27L10 - else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm + if (Int64.compare imm Int64.zero < 0) then + let length = signed_length imm + in if length <= 10 then S10 + else if length <= 32 then U27L5 + else if length <= 37 then U27L10 + else if length <= 64 then E27U27L10 + else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm + else + let length = unsigned_length imm + in if length <= 6 then U6 + else if length <= 10 then S10 + else if length <= 32 then U27L5 + else if length <= 37 then U27L10 + else if length <= 64 then E27U27L10 + 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"] -- cgit From 4206ca72bb9abf32949e4d31983762e46ef114ad Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 16:22:24 +0100 Subject: Rajout de commentaires sur les instructions non émises MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 8c6457a6..7650f50d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -414,8 +414,8 @@ Definition transl_op | 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) - | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") - | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") + | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") (* Normalement pas émis *) + | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (* Normalement pas émis *) | Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pdivw rd rs1 rs2 :: k) *) @@ -499,12 +499,12 @@ Definition transl_op | 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) - | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") - | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") - | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") - | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") - | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") - | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") + | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") (* Normalement pas émis *) + | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") (* Normalement pas émis *) + | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") (* Géré par fonction externe *) + | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") (* Géré par fonction externe *) + | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") (* Géré par fonction externe *) + | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") (* Géré par fonction externe *) | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 ::i k) -- cgit From 89c844205901b0ad1a1f04bdb0673f48bf1404a6 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 8 Mar 2019 16:55:00 +0100 Subject: Added error message for Odivfs in Asmblockgen --- mppa_k1c/Asmblockgen.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 7650f50d..1c176538 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -626,6 +626,7 @@ Definition transl_op | Odivf , _ => Error (msg "Asmblockgen.transl_op: Odivf") + | Odivfs, _ => Error (msg "Asmblockgen.transl_op: Odivfs") (* We use the Splitlong instead for these four conversions *) | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") -- cgit From 039d889f5f37f239d474bbc1eeebd258513cf209 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 10 Mar 2019 08:39:51 +0100 Subject: volatile load --- mppa_k1c/Asmexpand.ml | 74 +++++++++++++++++++++++++-------------------------- 1 file changed, 37 insertions(+), 37 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index cf06ebaf..751567f3 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -174,58 +174,59 @@ let expand_builtin_memcpy sz al args = (* Handling of volatile reads and writes *) -let expand_builtin_vload_common chunk base ofs res = assert false -(*match chunk, res with - | Mint8unsigned, BR(IR res) -> - emit (Plbu (res, base, Ofsimm ofs)) - | Mint8signed, BR(IR res) -> - emit (Plb (res, base, Ofsimm ofs)) - | Mint16unsigned, BR(IR res) -> - emit (Plhu (res, base, Ofsimm ofs)) - | Mint16signed, BR(IR res) -> - emit (Plh (res, base, Ofsimm ofs)) - | Mint32, BR(IR res) -> - emit (Plw (res, base, Ofsimm ofs)) - | Mint64, BR(IR res) -> - emit (Pld (res, base, Ofsimm ofs)) - | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> +let expand_builtin_vload_common chunk base ofs res = + match chunk, res with + | Mint8unsigned, BR(Asmblock.IR res) -> + emit (Plbu (res, base, Asmblock.Ofsimm ofs)) + | Mint8signed, BR(Asmblock.IR res) -> + emit (Plb (res, base, Asmblock.Ofsimm ofs)) + | Mint16unsigned, BR(Asmblock.IR res) -> + emit (Plhu (res, base, Asmblock.Ofsimm ofs)) + | Mint16signed, BR(Asmblock.IR res) -> + emit (Plh (res, base, Asmblock.Ofsimm ofs)) + | Mint32, BR(Asmblock.IR res) -> + emit (Plw (res, base, Asmblock.Ofsimm ofs)) + | Mint64, BR(Asmblock.IR res) -> + emit (Pld (res, base, Asmblock.Ofsimm ofs)) + | Mint64, BR_splitlong(BR(Asmblock.IR res1), BR(Asmblock.IR res2)) -> let ofs' = Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, Ofsimm ofs)); - emit (Plw (res1, base, Ofsimm ofs')) + emit (Plw (res2, base, Asmblock.Ofsimm ofs)); + emit (Plw (res1, base, Asmblock.Ofsimm ofs')) end else begin - emit (Plw (res1, base, Ofsimm ofs')); - emit (Plw (res2, base, Ofsimm ofs)) + emit (Plw (res1, base, Asmblock.Ofsimm ofs')); + emit (Plw (res2, base, Asmblock.Ofsimm ofs)) end - | Mfloat32, BR(FR res) -> - emit (Pfls (res, base, Ofsimm ofs)) - | Mfloat64, BR(FR res) -> - emit (Pfld (res, base, Ofsimm ofs)) + | Mfloat32, BR(Asmblock.IR res) -> + emit (Pfls (res, base, Asmblock.Ofsimm ofs)) + | Mfloat64, BR(Asmblock.IR res) -> + emit (Pfld (res, base, Asmblock.Ofsimm ofs)) | _ -> assert false -*) -let expand_builtin_vload chunk args res = assert false -(*match args with - | [BA(IR addr)] -> +let expand_builtin_vload chunk args res = + match args with + | [BA(Asmblock.IR addr)] -> expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk GPR12 ofs res + expand_builtin_vload_common chunk Asmblock.GPR12 ofs res else begin - expand_addptrofs GPR32 GPR12 ofs; (* X31 <- sp + ofs *) - expand_builtin_vload_common chunk GPR32 _0 res + assert false (* FIXME + expand_addptrofs Asmblock.GPR32 Asmblock.GPR12 ofs; (* X31 <- sp + ofs *) + expand_builtin_vload_common chunk GPR32 _0 res *) end - | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs))] -> + | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs))] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vload_common chunk addr ofs res else begin - expand_addptrofs GPR32 addr ofs; (* X31 <- addr + ofs *) - expand_builtin_vload_common chunk GPR32 _0 res + assert false (* FIXME + expand_addptrofs Asmblock.GPR32 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vload_common chunk Asmblock.GPR32 _0 res *) end | _ -> assert false -*) + let expand_builtin_vstore_common chunk base ofs src = assert false (*match chunk, src with @@ -475,9 +476,9 @@ let expand_instruction instr = begin match ef with | EF_builtin (name,sg) -> expand_builtin_inline (camlstring_of_coqstring name) args res - (*| EF_vload chunk -> + | EF_vload chunk -> expand_builtin_vload chunk args res - | EF_vstore chunk -> + (* | EF_vstore chunk -> expand_builtin_vstore chunk args | EF_annot_val (kind,txt,targ) -> expand_annot_val kind txt targ args res *) @@ -488,7 +489,6 @@ let expand_instruction instr = *) | EF_malloc -> failwith "asmexpand: malloc" | EF_free -> failwith "asmexpand: free" - | EF_vload _ -> failwith "asmexpand: vload" | EF_vstore _ -> failwith "asmexpand: vstore" | EF_debug _ -> failwith "asmexpand: debug" | EF_annot _ -> failwith "asmexpand: annot" -- cgit From 215a0343b8fb030ecb6367e71d9da8894c641e0e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 10 Mar 2019 09:16:20 +0100 Subject: volatile stores --- mppa_k1c/Asmexpand.ml | 83 +++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 43 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 751567f3..9afe61b8 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -26,7 +26,7 @@ open Camlcoq open !Integers exception Error of string - + (* Useful constants and helper functions *) let _0 = Integers.Int.zero @@ -41,6 +41,8 @@ let wordsize = if Archi.ptr64 then 8 else 4 let align n a = (n + a - 1) land (-a) +let stack_pointer = Asmblock.GPR12 + (* Emit instruction sequences that set or offset a register by a constant. *) (* let expand_loadimm32 dst n = @@ -120,8 +122,6 @@ let expand_annot_val kind txt targ args res = assert false (* Handling of memcpy *) -let stack_pointer = Asmblock.GPR12 - let offset_in_range ofs = let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L @@ -210,10 +210,10 @@ let expand_builtin_vload chunk args res = expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk Asmblock.GPR12 ofs res + expand_builtin_vload_common chunk stack_pointer ofs res else begin assert false (* FIXME - expand_addptrofs Asmblock.GPR32 Asmblock.GPR12 ofs; (* X31 <- sp + ofs *) + expand_addptrofs Asmblock.GPR32 stack_pointer ofs; (* X31 <- sp + ofs *) expand_builtin_vload_common chunk GPR32 _0 res *) end | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs))] -> @@ -228,49 +228,47 @@ let expand_builtin_vload chunk args res = assert false -let expand_builtin_vstore_common chunk base ofs src = assert false -(*match chunk, src with - | (Mint8signed | Mint8unsigned), BA(IR src) -> - emit (Psb (src, base, Ofsimm ofs)) - | (Mint16signed | Mint16unsigned), BA(IR src) -> - emit (Psh (src, base, Ofsimm ofs)) - | Mint32, BA(IR src) -> - emit (Psw (src, base, Ofsimm ofs)) - | Mint64, BA(IR src) -> - emit (Psd (src, base, Ofsimm ofs)) - | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> +let expand_builtin_vstore_common chunk base ofs src = + match chunk, src with + | (Mint8signed | Mint8unsigned), BA(Asmblock.IR src) -> + emit (Psb (src, base, Asmblock.Ofsimm ofs)) + | (Mint16signed | Mint16unsigned), BA(Asmblock.IR src) -> + emit (Psh (src, base, Asmblock.Ofsimm ofs)) + | Mint32, BA(Asmblock.IR src) -> + emit (Psw (src, base, Asmblock.Ofsimm ofs)) + | Mint64, BA(Asmblock.IR src) -> + emit (Psd (src, base, Asmblock.Ofsimm ofs)) + | Mint64, BA_splitlong(BA(Asmblock.IR src1), BA(Asmblock.IR src2)) -> let ofs' = Ptrofs.add ofs _4 in - emit (Psw (src2, base, Ofsimm ofs)); - emit (Psw (src1, base, Ofsimm ofs')) - | Mfloat32, BA(FR src) -> - emit (Pfss (src, base, Ofsimm ofs)) - | Mfloat64, BA(FR src) -> - emit (Pfsd (src, base, Ofsimm ofs)) + emit (Psw (src2, base, Asmblock.Ofsimm ofs)); + emit (Psw (src1, base, Asmblock.Ofsimm ofs')) + | Mfloat32, BA(Asmblock.IR src) -> + emit (Pfss (src, base, Asmblock.Ofsimm ofs)) + | Mfloat64, BA(Asmblock.IR src) -> + emit (Pfsd (src, base, Asmblock.Ofsimm ofs)) | _ -> assert false -*) -let expand_builtin_vstore chunk args = assert false -(*match args with - | [BA(IR addr); src] -> +let expand_builtin_vstore chunk args = + match args with + | [BA(Asmblock.IR addr); src] -> expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vstore_common chunk X2 ofs src - else begin + expand_builtin_vstore_common chunk stack_pointer ofs src + else begin (* FIXME expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) - expand_builtin_vstore_common chunk X31 _0 src + expand_builtin_vstore_common chunk X31 _0 src *) end - | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs)); src] -> + | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs)); src] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vstore_common chunk addr ofs src - else begin + else begin (* FIXME expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) - expand_builtin_vstore_common chunk X31 _0 src + expand_builtin_vstore_common chunk X31 _0 src *) end | _ -> assert false -*) (* Handling of varargs *) @@ -306,7 +304,7 @@ match !vararg_start_ofs with | None -> invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> - expand_addptrofs Asmblock.GPR32 Asmblock.GPR12 (Ptrofs.repr ofs); + expand_addptrofs Asmblock.GPR32 stack_pointer (Ptrofs.repr ofs); emit Psemi; expand_storeind_ptr Asmblock.GPR32 r Ptrofs.zero @@ -401,14 +399,14 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (Asmblock.GPR14, Asmblock.GPR12)); + emit (Pmv (Asmblock.GPR14, stack_pointer)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); + expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); emit Psemi; - expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; + expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; emit Psemi; let va_ofs = sz in @@ -416,9 +414,9 @@ let expand_instruction instr = vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin - expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); + expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); emit Psemi; - expand_storeind_ptr Asmblock.GPR14 Asmblock.GPR12 ofs; + expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; emit Psemi; vararg_start_ofs := None end @@ -429,7 +427,7 @@ let expand_instruction instr = let n = arguments_size sg in if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) end else 0 in - expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) (*| Pseqw(rd, rs1, rs2) -> (* emulate based on the fact that x == 0 iff x expand_builtin_vload chunk args res - (* | EF_vstore chunk -> + | EF_vstore chunk -> expand_builtin_vstore chunk args - | EF_annot_val (kind,txt,targ) -> +(* | EF_annot_val (kind,txt,targ) -> expand_annot_val kind txt targ args res *) | EF_memcpy(sz, al) -> expand_builtin_memcpy sz al args @@ -489,7 +487,6 @@ let expand_instruction instr = *) | EF_malloc -> failwith "asmexpand: malloc" | EF_free -> failwith "asmexpand: free" - | EF_vstore _ -> failwith "asmexpand: vstore" | EF_debug _ -> failwith "asmexpand: debug" | EF_annot _ -> failwith "asmexpand: annot" | EF_annot_val _ -> failwith "asmexpand: annot_val" -- cgit From e61f9334e0a964e358e93b94d5b24cf8d88e877a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 10:52:04 +0100 Subject: Fix for frame pointer being destroyed --- mppa_k1c/Asmexpand.ml | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 9afe61b8..cd6cf1ec 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -52,6 +52,8 @@ let expand_addptrofs dst src n = List.iter emit (basic_to_instruction (Asmblock.PArith (Asmblockgen.addptrofs dst src n)) :: []) let expand_storeind_ptr src base ofs = List.iter emit (basic_to_instruction (Asmblockgen.storeind_ptr src base ofs) :: []) +let expand_loadind_ptr dst base ofs = + List.iter emit (basic_to_instruction (Asmblockgen.loadind_ptr base ofs dst) :: []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack @@ -399,14 +401,15 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (Asmblock.GPR14, stack_pointer)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in - let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); - emit Psemi; - expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; + let full_sz = Z.add sz (Z.of_uint extra_sz) in begin + expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); + emit Psemi; + expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; + expand_addptrofs Asmblock.GPR14 stack_pointer (Ptrofs.repr full_sz) + end; emit Psemi; let va_ofs = sz in @@ -417,6 +420,7 @@ let expand_instruction instr = expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); emit Psemi; expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; + expand_addptrofs Asmblock.GPR14 stack_pointer (Ptrofs.repr sz); emit Psemi; vararg_start_ofs := None end @@ -427,6 +431,7 @@ let expand_instruction instr = let n = arguments_size sg in if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) end else 0 in + expand_loadind_ptr Asmblock.GPR14 stack_pointer ofs; expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) (*| Pseqw(rd, rs1, rs2) -> -- cgit From caffabfa75c2d42f1c8f2530ba06b6ea2bf02b36 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 12:02:37 +0100 Subject: [BROKEN] Added parallelizability check - breaks all the conditional jumps --- mppa_k1c/Asmblockdeps.v | 8 ++++++++ mppa_k1c/PostpassScheduling.v | 12 +++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 14355d32..b93a9e59 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -11,6 +11,7 @@ Require Import ZArith. Require Import Coqlib. Require Import ImpDep. Require Import Axioms. +Require Import Parallelizability. Open Scope impure. @@ -1444,3 +1445,10 @@ Definition bblock_equivb: Asmblock.bblock -> Asmblock.bblock -> bool := pure_bbl Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. End SECT. + +(** Parallelizability of a bblock *) + +Module PChk := ParallelChecks L PosResourceSet. + +Definition bblock_para_check (p: Asmblock.bblock) : bool := + PChk.is_parallelizable (trans_block p). diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 373c6a1b..b5d55ad3 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -336,12 +336,22 @@ Qed. Definition do_schedule (bb: bblock) : list bblock := if (Z.eqb (size bb) 1) then bb::nil else schedule bb. +Definition verify_par_bblock (bb: bblock) : res unit := + if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock"). + +Fixpoint verify_par (lbb: list bblock) := + match lbb with + | nil => OK tt + | bb :: lbb => do res <- verify_par_bblock bb; verify_par lbb + end. + Definition verified_schedule_nob (bb : bblock) : res (list bblock) := let bb' := no_header bb in let lbb := do_schedule bb' in do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; + do parcheck <- verify_par lbb; stick_header_code (header bb) lbb. Lemma verified_schedule_nob_size: @@ -368,7 +378,7 @@ Lemma verified_schedule_nob_header: /\ Forall (fun b => header b = nil) lbb. Proof. intros. split. - - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. + - monadInv H. unfold stick_header_code in EQ4. destruct (hd_error _); try discriminate. inv EQ4. simpl. reflexivity. - apply verified_schedule_nob_no_header_in_middle in H. assumption. Qed. -- cgit From 0e6e9bd0f68c5f628510603221463ed6b9fa2d54 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 12 Mar 2019 13:41:33 +0100 Subject: better tracing for ILP + make clean --- mppa_k1c/InstructionScheduler.ml | 9 ++++++--- mppa_k1c/PostpassSchedulingOracle.ml | 1 + 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 4f289780..73e73e15 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -1094,11 +1094,14 @@ let ilp_read_solution mapper channel = times;; let ilp_solver = ref "ilp_solver" - + +let problem_nr = ref 0 + let ilp_scheduler pb_type problem = try - let filename_in = "problem.lp" - and filename_out = "problem.sol" in + 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 opb_problem = open_out filename_in in let mapper = ilp_print_problem opb_problem problem pb_type in close_out opb_problem; diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 7b632144..20e10bf0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -685,6 +685,7 @@ let print_bb oc bb = let do_schedule bb = let problem = build_problem bb + (* can also use cascaded_scheduler *) in let solution = validated_scheduler list_scheduler problem in match solution with | None -> failwith "Could not find a valid schedule" -- cgit From e312c62c864611d88651bf745a14a67de40e3fd6 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 12 Mar 2019 15:28:49 +0100 Subject: fix trans_pcincr for parcheck. (Proof is broken. cf FIXME) --- mppa_k1c/Asmblockdeps.v | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b93a9e59..c58b2973 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -468,10 +468,10 @@ Definition trans_control (ctl: control) : macro := | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. -Definition trans_exit (ex: option control) : list L.macro := +Definition trans_exit (ex: option control) : L.macro := match ex with - | None => nil - | Some ctl => trans_control ctl :: nil + | None => [] + | Some ctl => trans_control ctl end . @@ -516,10 +516,10 @@ Fixpoint trans_body (b: list basic) : list L.macro := | b :: lb => (trans_basic b) :: (trans_body lb) end. -Definition trans_pcincr (sz: Z) := [(#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil))] :: nil. +Definition trans_pcincr (sz: Z) (k: L.macro) := [(#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k]. Definition trans_block (b: Asmblock.bblock) : L.bblock := - trans_body (body b) ++ trans_pcincr (size b) ++ trans_exit (exit b). + trans_body (body b) ++ trans_pcincr (size b) (trans_exit (exit b)). Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. Proof. @@ -812,7 +812,7 @@ Lemma forward_simu_control: exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> match_states (State rs m) s -> exists s', - exec Ge (trans_pcincr (size b) ++ trans_exit ex) s = Some s' + exec Ge (trans_pcincr (size b) (trans_exit ex)) s = Some s' /\ match_states (State rs2 m2) s'. Proof. intros. destruct ex. @@ -967,21 +967,21 @@ Lemma exec_trans_pcincr_exec: forall rs m s b, match_states (State rs m) s -> exists s', - exec Ge (trans_pcincr (size b) ++ trans_exit (exit b)) s = exec Ge (trans_exit (exit b)) s' + exec Ge (trans_pcincr (size b) (trans_exit (exit b))) s = exec Ge [trans_exit (exit b)] s' /\ match_states (State (nextblock b rs) m) s'. Proof. intros. inv H. eexists. split. simpl. - unfold control_eval. pose (H1 PC); simpl in e; rewrite e. destruct Ge. reflexivity. + unfold control_eval. pose (H1 PC); simpl in e; rewrite e. destruct Ge. (* eapply eq_refl. simpl. split. - Simpl. - - intros rr; destruct rr; Simpl. -Qed. + - intros rr; destruct rr; Simpl.*) +Admitted. (* FIXME *) Lemma exec_exit_none: forall ge fn rs m s ex, Ge = Genv ge fn -> match_states (State rs m) s -> - exec Ge (trans_exit ex) s = None -> + exec Ge [trans_exit ex] s = None -> exec_control ge fn ex rs m = Stuck. Proof. intros. inv H0. destruct ex as [ctl|]; try discriminate. @@ -1092,7 +1092,7 @@ Lemma forward_simu_exit_stuck: Ge = Genv ge fn -> exec_control ge fn ex rs m = Stuck -> match_states (State rs m) s -> - exec Ge (trans_exit ex) s = None. + exec Ge [(trans_exit ex)] s = None. Proof. intros. inv H1. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). -- cgit From 0a79f162def6934a1c8520d408521a8d3008ac19 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 15:36:36 +0100 Subject: Simplification des preuves "de discrimination" dans Asmblockdeps --- mppa_k1c/Asmblockdeps.v | 171 ++++++++++++++++++++++-------------------------- 1 file changed, 77 insertions(+), 94 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b93a9e59..b82ff5e1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -405,6 +405,8 @@ Import P. Section SECT. Variable Ge: genv. +Local Open Scope positive_scope. + Definition pmem : R.t := 1. Definition ireg_to_pos (ir: ireg) : R.t := @@ -419,7 +421,51 @@ Definition ireg_to_pos (ir: ireg) : R.t := end . -Local Open Scope positive_scope. +Lemma ireg_to_pos_discr: forall r r', r <> r' -> ireg_to_pos r <> ireg_to_pos r'. +Proof. + destruct r; destruct r'; try contradiction; discriminate. +Qed. + +Definition ppos (r: preg) : R.t := + match r with + | RA => 2 + | PC => 3 + | IR ir => 3 + ireg_to_pos ir + end +. + +Notation "# r" := (ppos r) (at level 100, right associativity). + +Lemma not_eq_add: + forall k n n', n <> n' -> k + n <> k + n'. +Proof. + intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. +Qed. + +Lemma ppos_discr: forall r r', r <> r' -> ppos r <> ppos r'. +Proof. + destruct r; destruct r'. + all: try discriminate; try contradiction. + - intros. apply not_eq_add. apply ireg_to_pos_discr. congruence. + - intros. unfold ppos. cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. + apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + - intros. unfold ppos. rewrite Pos.add_comm. apply Pos.add_no_neutral. + - intros. unfold ppos. apply not_eq_sym. + cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. + apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + - intros. unfold ppos. apply not_eq_sym. rewrite Pos.add_comm. apply Pos.add_no_neutral. +Qed. + +Lemma ppos_pmem_discr: forall r, pmem <> ppos r. +Proof. + intros. destruct r. + - unfold ppos. unfold pmem. apply not_eq_sym. rewrite Pos.add_comm. cutrewrite (3 = 2 + 1). rewrite Pos.add_assoc. apply Pos.add_no_neutral. + reflexivity. + - unfold ppos. unfold pmem. discriminate. + - unfold ppos. unfold pmem. discriminate. +Qed. + +(** Inversion functions, used for debugging *) Definition pos_to_ireg (p: R.t) : option gpreg := match p with @@ -433,14 +479,6 @@ Definition pos_to_ireg (p: R.t) : option gpreg := | _ => None end. -Definition ppos (r: preg) : R.t := - match r with - | RA => 2 - | PC => 3 - | IR ir => 3 + ireg_to_pos ir - end -. - Definition inv_ppos (p: R.t) : option preg := match p with | 1 => None @@ -451,7 +489,8 @@ Definition inv_ppos (p: R.t) : option preg := end end. -Notation "# r" := (ppos r) (at level 100, right associativity). + +(** Traduction Asmblock -> Asmblockdeps *) Notation "a @ b" := (Econs a b) (at level 102, right associativity). @@ -555,50 +594,6 @@ Definition trans_state (s: Asmblock.state) : state := | None => Val Vundef end. -Lemma pos_gpreg_not: forall g: gpreg, pmem <> (#g) /\ 2 <> (#g) /\ 3 <> (#g). -Proof. - intros. split; try split. all: destruct g; try discriminate. -Qed. - -Lemma not_3_plus_n: - forall n, 3 + n <> pmem /\ 3 + n <> (# RA) /\ 3 + n <> (# PC). -Proof. - intros. split; try split. - all: destruct n; simpl; try (destruct n; discriminate); try discriminate. -Qed. - -Lemma not_eq_add: - forall k n n', n <> n' -> k + n <> k + n'. -Proof. - intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. -Qed. - -Lemma not_eq_ireg_to_pos: - forall n r r', r' <> r -> n + ireg_to_pos r <> n + ireg_to_pos r'. -Proof. - intros. destruct r; destruct r'; try contradiction; apply not_eq_add; discriminate. -Qed. - -Lemma not_eq_ireg_ppos: - forall r r', r <> r' -> (# r') <> (# r). -Proof. - intros. unfold ppos. destruct r. - - destruct r'; try discriminate. - + apply not_eq_ireg_to_pos; congruence. - + destruct g; discriminate. - + destruct g; discriminate. - - destruct r'; try discriminate; try contradiction. - destruct g; discriminate. - - destruct r'; try discriminate; try contradiction. - destruct g; discriminate. -Qed. - -Lemma not_eq_ireg_to_pos_ppos: - forall r r', r' <> r -> 3 + ireg_to_pos r <> # r'. -Proof. - intros. unfold ppos. apply not_eq_ireg_to_pos. assumption. -Qed. - Lemma not_eq_IR: forall r r', r <> r' -> IR r <> IR r'. Proof. @@ -611,13 +606,15 @@ Ltac Simplif := || (rewrite Pregmap.gss) || (rewrite nextblock_pc) || (rewrite Pregmap.gso by eauto with asmgen) - || (rewrite assign_diff by (try discriminate; try (apply pos_gpreg_not); try (apply not_3_plus_n); try (apply not_eq_ireg_ppos; apply not_eq_IR; auto); try (apply not_eq_ireg_to_pos_ppos; auto))) + || (rewrite assign_diff by (auto; try discriminate; try (apply ppos_discr; try discriminate; congruence); try (apply ppos_pmem_discr); + try (apply not_eq_sym; apply ppos_discr; try discriminate; congruence); try (apply not_eq_sym; apply ppos_pmem_discr); auto)) || (rewrite assign_eq) ); auto with asmgen. Ltac Simpl := repeat Simplif. Arguments Pos.add: simpl never. +Arguments ppos: simpl never. Theorem trans_state_match: forall S, match_states S (trans_state S). Proof. @@ -664,11 +661,11 @@ Proof. destruct (ireg_eq g rd); subst; Simpl. (* PArithRR *) - inv H; inv H0; - eexists; split; try split; - [ simpl; pose (H1 rs0); simpl in e; rewrite e; reflexivity | - Simpl | - intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); subst; Simpl ]. + eexists; split; try split. + * simpl. pose (H1 rs0). rewrite e; reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. (* PArithRI32 *) - inv H. inv H0. eexists; split; try split. @@ -695,24 +692,25 @@ Proof. destruct (ireg_eq g rd); subst; Simpl. (* PArithRRR *) - inv H; inv H0; - eexists; split; try split; - [ simpl; pose (H1 rs1); simpl in e; rewrite e; pose (H1 rs2); simpl in e0; rewrite e0; try (rewrite H); reflexivity - | Simpl - | intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); subst; Simpl ]. + eexists; split; try split. + * simpl. pose (H1 rs1); rewrite e. pose (H1 rs2); rewrite e0. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. (* PArithRRI32 *) - inv H; inv H0; - eexists; split; try split; - [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); auto - | Simpl - | intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); subst; Simpl ]. + eexists; split; try split. + * simpl. pose (H1 rs0); rewrite e. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRI64 *) - inv H; inv H0; - eexists; split; try split; - [ simpl; pose (H1 rs0); simpl in e; rewrite e; try (rewrite H); reflexivity - | Simpl - | intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); subst; Simpl ]. + eexists; split; try split. + * simpl. pose (H1 rs0); rewrite e. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. Qed. Lemma forward_simu_basic: @@ -751,14 +749,8 @@ Proof. * simpl. Simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite MEMAL. rewrite MEMS. Simpl. rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]. - ** subst. Simpl. - ** subst. Simpl. - ** subst. Simpl. - ** Simpl. repeat (rewrite assign_diff). auto. - pose (not_eq_ireg_to_pos_ppos GPR14 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos GPR12 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos GPR32 g). simpl ireg_to_pos in n2. auto. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. (* Freeframe *) - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rs GPR12) eqn:SPeq; try discriminate. destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv H0. @@ -766,20 +758,11 @@ Proof. * simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. Simpl. rewrite e. rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]. - ** subst. Simpl. - ** subst. Simpl. - ** subst. Simpl. - ** Simpl. repeat (rewrite assign_diff). auto. - unfold ppos. pose (not_3_plus_n (ireg_to_pos g)). destruct a as (A & _ & _). auto. - pose (not_eq_ireg_to_pos_ppos GPR12 g). simpl ireg_to_pos in n2. auto. - pose (not_eq_ireg_to_pos_ppos GPR32 g). simpl ireg_to_pos in n2. auto. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. (* Pget *) - simpl in H. destruct rs0 eqn:rs0eq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd). - * subst. Simpl. - * Simpl. + destruct (ireg_eq g rd); subst; Simpl. (* Pset *) - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. -- cgit From 720caa808c6de6b0e672e69f9bc8395d2b43723e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 16:45:10 +0100 Subject: Proof of exec_trans_pcincr solved --- mppa_k1c/Asmblockdeps.v | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index d685bd75..616c5f2a 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -946,6 +946,28 @@ Proof. eapply IHc; eauto. Qed. +Lemma exec_trans_pcincr_exec_macrorun: + forall rs m s b k, + match_states (State rs m) s -> + exists s', + macro_run Ge ((# PC, Op (OIncremPC (size b)) (Name (# PC) @ Enil)) :: k) s s = macro_run Ge k s' s + /\ match_states (State (nextblock b rs) m) s'. +Proof. + intros. inv H. eexists. split. simpl. pose (H1 PC); simpl in e; rewrite e. destruct Ge. simpl. eapply eq_refl. + simpl. split. + - Simpl. + - intros rr; destruct rr; Simpl. +Qed. + +Lemma macro_run_trans_exit_noold: + forall ex s s' s'', + macro_run Ge (trans_exit ex) s s' = macro_run Ge (trans_exit ex) s s''. +Proof. + intros. destruct ex. + - destruct c; destruct i; reflexivity. + - reflexivity. +Qed. + Lemma exec_trans_pcincr_exec: forall rs m s b, match_states (State rs m) s -> @@ -953,12 +975,13 @@ Lemma exec_trans_pcincr_exec: exec Ge (trans_pcincr (size b) (trans_exit (exit b))) s = exec Ge [trans_exit (exit b)] s' /\ match_states (State (nextblock b rs) m) s'. Proof. - intros. inv H. eexists. split. simpl. - unfold control_eval. pose (H1 PC); simpl in e; rewrite e. destruct Ge. (* eapply eq_refl. - simpl. split. - - Simpl. - - intros rr; destruct rr; Simpl.*) -Admitted. (* FIXME *) + intros. + exploit exec_trans_pcincr_exec_macrorun; eauto. + intros (s' & MRUN & MS). + eexists. split. unfold exec. unfold trans_pcincr. unfold run. rewrite MRUN. + erewrite macro_run_trans_exit_noold; eauto. + assumption. +Qed. Lemma exec_exit_none: forall ge fn rs m s ex, @@ -1018,7 +1041,8 @@ Proof. - right. repeat eexists. exploit exec_body_next_exec; eauto. intros (s' & EXECBK' & MS'). unfold trans_block in EXECBK. rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. - exploit exec_trans_pcincr_exec; eauto. intros (s'' & EXECINCR' & MS''). rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. + exploit exec_trans_pcincr_exec; eauto. intros (s'' & EXECINCR' & MS''). + rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. eapply exec_exit_none; eauto. - left. reflexivity. Qed. -- cgit From 8f337598016aa49ff6554085b406b7e6026bfc3d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 12 Mar 2019 17:22:46 +0100 Subject: -fpostpass-ilp --- mppa_k1c/PostpassSchedulingOracle.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 20e10bf0..3dee7622 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -685,8 +685,10 @@ let print_bb oc bb = let do_schedule bb = let problem = build_problem bb - (* can also use cascaded_scheduler *) - in let solution = validated_scheduler list_scheduler problem + in let solution = validated_scheduler + (if !Clflags.option_fpostpass_ilp + then cascaded_scheduler + else list_scheduler) problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From 60c0b75a8dcf475d3fb443e0dac50dac34e01d12 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 17:58:48 +0100 Subject: Added a flag for changing the scheduler (not any choice available right now) --- mppa_k1c/PostpassSchedulingOracle.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 7b632144..4d448df3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -684,8 +684,9 @@ let print_bb oc bb = in List.iter (print_inst oc) asm_instructions let do_schedule bb = - let problem = build_problem bb - in let solution = validated_scheduler list_scheduler problem + let scheduler = match Compopts.optim_pp_optimizer () with 1 -> list_scheduler | _ -> failwith "No scheduler provided" + in let problem = build_problem bb + in let solution = validated_scheduler scheduler problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From 50f25f57749d3eb46d859350719c9324fb75afa2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 12 Mar 2019 18:03:22 +0100 Subject: Added cascaded_scheduler but the flag does not work --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 4d448df3..c339702e 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -684,7 +684,7 @@ let print_bb oc bb = in List.iter (print_inst oc) asm_instructions let do_schedule bb = - let scheduler = match Compopts.optim_pp_optimizer () with 1 -> list_scheduler | _ -> failwith "No scheduler provided" + let scheduler = match Compopts.optim_pp_optimizer () with 1 -> list_scheduler | 2 -> cascaded_scheduler | _ -> failwith "No scheduler provided" in let problem = build_problem bb in let solution = validated_scheduler scheduler problem in match solution with -- cgit From 04b05b8039f7b306d8dacbf7bd0ec58ba7dc209d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 13 Mar 2019 05:24:08 +0100 Subject: for using CPlex --- mppa_k1c/InstructionScheduler.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 73e73e15..ce687678 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -1050,6 +1050,17 @@ let ilp_print_problem channel problem pb_type = mapper_final_predecessors = predecessors.(nr_instructions) };; +(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) + +let positive_float_round x = truncate (x +. 0.5) + +let float_round (x : float) : int = + if x > 0.0 + then positive_float_round x + else - (positive_float_round (-. x)) + +let rounded_int_of_string x = float_round (float_of_string x) + let ilp_read_solution mapper channel = let times = Array.make (match mapper.mapper_pb_type with @@ -1075,7 +1086,7 @@ 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 int_of_string (String.sub line (space+1) ((String.length line)-space-1)) + try rounded_int_of_string (String.sub line (space+1) ((String.length line)-space-1)) with Failure _ -> failwith "bad ilp output: not a time number" in -- cgit From 8f972659841ad38f6f548161b5ca3cfcbdd135cb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Mar 2019 10:53:15 +0100 Subject: Enlevé la dépendance mémoire de Pcbu MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 4 ++-- mppa_k1c/Asmblockdeps.v | 40 ++++++++++++++++++++-------------------- mppa_k1c/Asmblockgenproof1.v | 6 +++--- 3 files changed, 25 insertions(+), 25 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9938b386..621ed8a7 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1390,8 +1390,8 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) end | Pcbu bt r l => match cmpu_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs#r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs#r (Vlong (Int64.repr 0))) + | (Some c, Int) => eval_branch f l rs m (Val_cmpu_bool c rs#r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val_cmplu_bool c rs#r (Vlong (Int64.repr 0))) | (None, _) => Stuck end diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 616c5f2a..c6052337 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -179,10 +179,10 @@ Definition control_eval (o: control_op) (l: list value) := | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmpl_bool c v (Vlong (Int64.repr 0))) | (None, _) => None end - | Ocbu bt l, [Val v; Val vpc; Memstate m] => + | Ocbu bt l, [Val v; Val vpc] => match cmpu_for_btest bt with - | (Some c, Int) => eval_branch_deps fn l vpc (Val.cmpu_bool (Mem.valid_pointer m) c v (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong (Int64.repr 0))) + | (Some c, Int) => eval_branch_deps fn l vpc (Val_cmpu_bool c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val_cmplu_bool c v (Vlong (Int64.repr 0))) | (None, _) => None end | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) @@ -503,7 +503,7 @@ Definition trans_control (ctl: control) : macro := | Pigoto r => [(#PC, Name (#r))] | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] - | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Name pmem @ Enil))] + | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. @@ -844,34 +844,34 @@ Proof. * intros rr; destruct rr; Simpl. (* Pcbu *) + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold eval_branch in H0. destruct (Val.cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + ++ unfold eval_branch in H0. destruct (Val_cmpu_bool _ _) eqn:VALCMP; try discriminate. destruct b0. +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. inv H0. eexists; split; try split. * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. +++ inv H0. eexists; split; try split. * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. - ++ unfold eval_branch in H0. destruct (Val.cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. + ++ unfold eval_branch in H0. destruct (Val_cmplu_bool _ _) eqn:VALCMP; try discriminate. destruct b0. +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. inv H0. eexists; split; try split. * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. +++ inv H0. eexists; split; try split. * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. rewrite H2. pose (H3 r). simpl in e0. rewrite e0. + rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. @@ -1013,17 +1013,17 @@ Proof. (* Pcbu *) - simpl in *. destruct (cmpu_for_btest bt). destruct i. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. rewrite H2 in H1. + destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. unfold eval_branch_deps in H1; unfold eval_branch. - destruct (Val.cmpu_bool _ _ _ _); auto. destruct b; try discriminate. + destruct (Val_cmpu_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. rewrite H2 in H1. + destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. unfold eval_branch_deps in H1; unfold eval_branch. - destruct (Val.cmplu_bool _ _ _); auto. destruct b; try discriminate. + destruct (Val_cmplu_bool _ _); auto. destruct b; try discriminate. unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. Qed. @@ -1123,17 +1123,17 @@ Proof. (* Pcbu *) - simpl in *. destruct (cmpu_for_btest bt). destruct i. -- destruct o. - + rewrite H2. unfold eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmpu_bool _ _ _); auto. + + unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmpu_bool _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + rewrite H2. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. + + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. -- destruct o. - + rewrite H2. unfold eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmplu_bool _ _ _); auto. + + unfold eval_branch in H0; unfold eval_branch_deps. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmplu_bool _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + rewrite H2. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. + + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. Qed. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1a55f58e..5486a497 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -743,7 +743,7 @@ Lemma transl_opt_compuimm_correct: exists rs', exists insn, exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 (Vint n) = Some b -> + /\ ( Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -819,7 +819,7 @@ Lemma transl_opt_compluimm_correct: exists rs', exists insn, exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 (Vlong n) = Some b -> + /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -1016,7 +1016,7 @@ Proof. exists rs', i. split. * apply A. - * split; auto. apply C. apply EVAL'. + * split; eauto. (* apply C. apply EVAL'. *) + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 RTMP n ::g transl_compl c0 Unsigned x RTMP lbl k). { unfold transl_opt_compluimm. destruct (Int64.eq n Int64.zero) eqn:EQN. -- cgit From eb56a0fcc6f9f91064b6b0707e92c3b734457ccd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Mar 2019 13:58:48 +0100 Subject: Fix for CompCert 3.5 --- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 46f2d387..e7c7a9fb 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -4,6 +4,7 @@ Require Extraction. Require Import Ascii. Require Import BinNums. Require Export ImpCore. +Require Export PArith. Axiom caml_string: Type. Extract Constant caml_string => "string". -- cgit From 802badd4bdf9b0e836935b74a25facb245558004 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 13 Mar 2019 15:42:32 +0100 Subject: Corrigé certaines latences (Store -> 1 i/o 3, Set -> 4 i/o 3) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingOracle.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3dee7622..9700776c 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -529,11 +529,10 @@ let real_inst_to_latency = function -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld - | Sb | Sh | Sw | Sd - -> 3 (* FIXME - random value *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> 3 + | Sb | Sh | Sw | Sd -> 1 (* See k1c-Optimization.pdf page 19 *) | Get -> 1 - | Set -> 3 + | 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 -- cgit From afa25aac9373e4a7b37433ed861257a630264c29 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Mar 2019 11:42:11 +0100 Subject: definition of VLIW semantics --- mppa_k1c/Asmblock.v | 18 +- mppa_k1c/Asmvliw.v | 329 +++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassSchedulingproof.v | 9 +- 3 files changed, 342 insertions(+), 14 deletions(-) create mode 100644 mppa_k1c/Asmvliw.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 621ed8a7..b656789b 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -801,10 +801,10 @@ Section RELSEM. set and memory state after execution of the instruction at [rs#PC], or [Stuck] if the processor is stuck. *) -Inductive outcome {rgset}: Type := - | Next (rs:rgset) (m:mem) +Inductive outcome: Type := + | Next (rs:regset) (m:mem) | Stuck. -Arguments outcome: clear implicits. +(* Arguments outcome: clear implicits. *) (** ** Arithmetic Expressions (including comparisons) *) @@ -1221,7 +1221,7 @@ Definition store_chunk n := (** * basic instructions *) -Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset := +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := match bi with | PArith ai => Next (exec_arith_instr ai rs) m @@ -1263,7 +1263,7 @@ Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset : | Pnop => Next rs m end. -Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome regset := +Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := match body with | nil => Next rs m | bi::body' => @@ -1323,7 +1323,7 @@ Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' end. -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome regset := +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := match label_pos lbl 0 (fn_blocks f) with | None => Stuck | Some pos => @@ -1338,7 +1338,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome 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 regset := +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := match res with | Some true => goto_label f l rs m | Some false => Next rs m @@ -1362,7 +1362,7 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti we generate cannot use those registers to hold values that must survive the execution of the pseudo-instruction. *) -Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome regset := +Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := match oc with | Some ic => (** Get/Set system registers *) @@ -1403,7 +1403,7 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) | None => Next rs m end. -Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := +Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := match exec_body (body b) rs0 m with | Next rs' m' => let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v new file mode 100644 index 00000000..2c88673b --- /dev/null +++ b/mppa_k1c/Asmvliw.v @@ -0,0 +1,329 @@ +(* *********************************************************************) +(* *) +(* 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 Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Errors. +Require Import Asmblock. + +Local Open Scope asm. + +Section RELSEM. + +(** Execution of arith instructions *) + +Variable ge: genv. + +(* TODO: on pourrait mettre ça dans Asmblock pour factoriser le code + en définissant + exec_arith_instr ai rs := parexec_arith_instr ai rs rs +*) +Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := + match ai with + | PArithR n d => rsw#d <- (arith_eval_r ge n) + + | PArithRR n d s => rsw#d <- (arith_eval_rr n rsr#s) + + | PArithRI32 n d i => rsw#d <- (arith_eval_ri32 n i) + | PArithRI64 n d i => rsw#d <- (arith_eval_ri64 n i) + | PArithRF32 n d i => rsw#d <- (arith_eval_rf32 n i) + | PArithRF64 n d i => rsw#d <- (arith_eval_rf64 n i) + + | PArithRRR n d s1 s2 => rsw#d <- (arith_eval_rrr n rsr#s1 rsr#s2) + + | PArithRRI32 n d s i => rsw#d <- (arith_eval_rri32 n rsr#s i) + + | PArithRRI64 n d s i => rsw#d <- (arith_eval_rri64 n rsr#s i) + end. + +(** * load/store *) + +(* TODO: factoriser ? *) +Definition parexec_load (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) + (d: ireg) (a: ireg) (ofs: offset) := + match (eval_offset ge ofs) with + | OK ptr => + match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with + | None => Stuck + | Some v => Next (rsw#d <- v) mw + end + | _ => Stuck + end. + +(* rem: parexec_store = exec_store *) + +(** * basic instructions *) + +(* TODO: factoriser ? *) +Definition parexec_basic_instr (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 (load_chunk n) rsr rsw mr mw d a ofs + + | PStoreRRO n s a ofs => exec_store ge (store_chunk n) rsr mr s a ofs + + | Pallocframe sz pos => + let (mw, stk) := Mem.alloc mr 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr mw (Val.offset_ptr sp pos) rsr#SP with + | None => Stuck + | Some mw => Next (rsw #FP <- (rsr SP) #SP <- sp #RTMP <- Vundef) mw + end + + | Pfreeframe sz pos => + match Mem.loadv Mptr mr (Val.offset_ptr rsr#SP pos) with + | None => Stuck + | Some v => + match rsr SP with + | Vptr stk ofs => + match Mem.free mr stk 0 sz with + | None => Stuck + | Some mw => Next (rsw#SP <- v #RTMP <- Vundef) mw + end + | _ => Stuck + end + end + | Pget rd ra => + match ra with + | RA => Next (rsw#rd <- (rsr#ra)) mw + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rsw#ra <- (rsr#rd)) mw + | _ => Stuck + end + | Pnop => Next rsw mw +end. + +(* parexec with writes-in-order *) +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 + | Next rsw mw => parexec_wio_body body' rsr rsw mr mw + | Stuck => Stuck + end + end. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextblock]) or branching to a label ([goto_label]). *) + +(* TODO: factoriser ? *) +Definition par_nextblock size_b (rsr rsw: regset) := + rsw#PC <- (Val.offset_ptr rsr#PC size_b). + +(* TODO: factoriser ? *) +Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := + match label_pos lbl 0 (fn_blocks f) with + | None => Stuck + | Some pos => + match rsr#PC with + | Vptr b ofs => Next (rsw#PC <- (Vptr b (Ptrofs.repr pos))) mw + | _ => Stuck + end + end. + +(** Evaluating a branch + +Warning: in m PC is assumed to be already pointing on the next instruction ! + +*) +(* TODO: factoriser ? *) +Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) (res: option bool) := + match res with + | Some true => par_goto_label f l rsr rsw mw + | Some false => Next rsw mw + | None => Stuck + end. + + +(** Execution of a single control-flow instruction [i] in initial state [rs] and + [m]. Return updated state. + + As above: PC is assumed to be incremented on the next block before the control-flow instruction + + 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. + + 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 parexec_control (f: function) (oc: option control) (rsr rsw: regset) (mw: mem) := + match oc with + | Some ic => +(** Get/Set system registers *) + match ic with + + +(** Branch Control Unit instructions *) + | Pret => + Next (rsw#PC <- (rsr#RA)) mw + | Pcall s => + Next (rsw#RA <- (rsr#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw + | Picall r => + Next (rsw#RA <- (rsr#PC) #PC <- (rsr#r)) mw + | Pgoto s => + Next (rsw#PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw + | Pigoto r => + Next (rsw#PC <- (rsr#r)) mw + | Pj_l l => + par_goto_label f l rsr rsw mw + | Pcb bt r l => + match cmp_for_btest bt with + | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val.cmp_bool c rsr#r (Vint (Int.repr 0))) + | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val.cmpl_bool c rsr#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val_cmpu_bool c rsr#r (Vint (Int.repr 0))) + | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val_cmplu_bool c rsr#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + + +(** Pseudo-instructions *) + | Pbuiltin ef args res => + Stuck (**r treated specially below *) + end + | None => Next rsw mw +end. + + +Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rs: regset) (m: mem): outcome := + match parexec_wio_body bdy rs rs m m with + | Next rsw mw => + let rsw := par_nextblock size_b rs rsw in + parexec_control f ext rs rsw mw + | Stuck => Stuck + end. + +(* utile ? *) +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 m. + + +Require Import Sorting.Permutation. + +Inductive parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome -> Prop := + parexec_bblock_Next bdy1 bdy2 rsw mw: + Permutation (bdy1++bdy2) (body b) -> + parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Next rsw mw -> + parexec_bblock f b rs m (parexec_wio_body bdy2 rs rsw m mw) + | parexec_bblock_Stuck bdy1 bdy2: + Permutation (bdy1++bdy2) (body b) -> + parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Stuck -> + parexec_bblock f b rs m Stuck. + + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bi rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> + exec_bblock ge f bi rs m = Next rs' m' -> + parexec_bblock f bi rs m (Next rs' m') -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' bi, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextblock bi + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#RTMP <- Vundef))) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> + step (State rs m) t (State rs' m') + . + +End RELSEM. + +(** Execution of whole programs. *) + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + + split. constructor. auto. + + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate. + rewrite H10 in H4. discriminate. + + unfold exec_bblock in H14. (* FIXME: destruct (exec_body _ _ _ _); try discriminate. + rewrite H4 in H13. discriminate. + + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H6. eexact H13. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. *) +Admitted. \ No newline at end of file diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2de49faa..2e463f18 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -67,11 +67,10 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -Lemma next_eq {A: Type}: - forall (rs rs':A) m m', +Lemma next_eq rs rs' m m': rs = rs' -> m = m' -> Next rs m = Next rs' m'. Proof. - intros. congruence. + intros; apply f_equal2; auto. Qed. Lemma regset_double_set: @@ -659,8 +658,8 @@ Proof. eapply external_call_symbols_preserved; eauto. apply senv_preserved. Qed. -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). (* FIXME a remplacer par Asmvliw.semantics tprog *) Proof. eapply forward_simulation_plus. - apply senv_preserved. -- cgit From 0dd01dbafe5125d69562640534fca6fe79fa9d82 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 14 Mar 2019 21:41:44 +0100 Subject: better robustness wrt exceptions --- mppa_k1c/InstructionScheduler.ml | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index ce687678..dca4b8ff 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -1107,16 +1107,20 @@ 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 opb_problem = open_out filename_in in - let mapper = ilp_print_problem opb_problem problem pb_type in - close_out opb_problem; - + let mapper = do_with_resource close_out (open_out filename_in) + (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in begin match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with | Unix.WEXITED 0 -> -- cgit From 2636b70dc48752ce21221c1fcf18c7a83086171d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Mar 2019 21:45:18 +0100 Subject: fix the step_internal of Asmvliw - Actually, we want to show that the outcome is the same for any order of "writes" in the parallel execution. (ie we ask that bundles have a deterministic semantics for parallel execution) - we relax the condition that the outcome should be given for sequential execution instead, we ask that the it is given for the "in order" writes. In theory, the semantics would also accept bundles like "R1 := R2 R2 := R1" which are deterministic for parallel execution But, of course, in practice, we will also prove the sequential execution. --- mppa_k1c/Asmvliw.v | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 2c88673b..5b58118b 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -233,23 +233,27 @@ Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rs: regset) (m: | Stuck => Stuck end. -(* utile ? *) 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 m. - Require Import Sorting.Permutation. -Inductive parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome -> Prop := - parexec_bblock_Next bdy1 bdy2 rsw mw: - Permutation (bdy1++bdy2) (body b) -> - parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Next rsw mw -> - parexec_bblock f b rs m (parexec_wio_body bdy2 rs rsw m mw) - | parexec_bblock_Stuck bdy1 bdy2: - Permutation (bdy1++bdy2) (body b) -> - parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Stuck -> - parexec_bblock f b rs m Stuck. +Definition parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem) (o: outcome): Prop := + exists bdy1 bdy2, Permutation (bdy1++bdy2) (body b) /\ + o=match parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m with + | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw + | Stuck => Stuck + end. +Lemma parexec_bblock_write_in_order f b rs m: + parexec_bblock f b rs m (parexec_wio_bblock f b rs m). +Proof. + exists (body b). exists nil. + constructor 1. + - rewrite app_nil_r; auto. + - unfold parexec_wio_bblock. + destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. +Qed. Inductive step: state -> trace -> state -> Prop := | exec_step_internal: @@ -257,8 +261,8 @@ Inductive step: state -> trace -> state -> Prop := rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> - exec_bblock ge f bi rs m = Next rs' m' -> - parexec_bblock f bi rs m (Next rs' m') -> + parexec_wio_bblock f bi rs m = Next rs' m' -> + (forall o, parexec_bblock f bi rs m o -> o=(Next rs' m')) -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' bi, @@ -301,11 +305,11 @@ Ltac Equalities := intros; constructor; simpl; intros. - (* determ *) inv H; inv H0; Equalities. - + split. constructor. auto. - + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate. + + split. constructor. auto. + + unfold parexec_wio_bblock, parexec_wio_bblock_aux in H4. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. rewrite H10 in H4. discriminate. - + unfold exec_bblock in H14. (* FIXME: destruct (exec_body _ _ _ _); try discriminate. - rewrite H4 in H13. discriminate. + + unfold parexec_wio_bblock, parexec_wio_bblock_aux in H11. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + rewrite H4 in H11. discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. exploit external_call_determ. eexact H6. eexact H13. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. @@ -325,5 +329,5 @@ Ltac Equalities := inv H. unfold Vzero in H0. red; intros; red; intros. inv H; rewrite H0 in *; eelim NOTNULL; eauto. - (* final states *) - inv H; inv H0. congruence. *) -Admitted. \ No newline at end of file + inv H; inv H0. congruence. +Qed. \ No newline at end of file -- cgit From fbe5ac2c9619441ad84dedf3c0cdabb315f9f974 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 15 Mar 2019 11:05:33 +0100 Subject: Removing SelectLong.v from the git repo (compiled from SelectLong.vp) --- mppa_k1c/SelectLong.v | 783 ------------------------------------------------- mppa_k1c/SelectLong.vp | 18 +- 2 files changed, 1 insertion(+), 800 deletions(-) delete mode 100644 mppa_k1c/SelectLong.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.v b/mppa_k1c/SelectLong.v deleted file mode 100644 index ea42b9c3..00000000 --- a/mppa_k1c/SelectLong.v +++ /dev/null @@ -1,783 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* 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. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for 64-bit integer operations *) - -Require Import Coqlib. -Require Import Compopts. -Require Import AST Integers Floats. -Require Import Op CminorSel. -Require Import SelectOp SplitLong. - -Local Open Scope cminorsel_scope. -Local Open Scope string_scope. - -Section SELECT. - -Context {hf: helper_functions}. - -Definition longconst (n: int64) : expr := - if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. - -Definition is_longconst (e: expr) := - if Archi.splitlong then SplitLong.is_longconst e else - match e with - | Eop (Olongconst n) Enil => Some n - | _ => None - end. - -Definition intoflong (e: expr) := - if Archi.splitlong then SplitLong.intoflong e else - match is_longconst e with - | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil - | None => Eop Olowlong (e ::: Enil) - end. - -Definition longofint (e: expr) := - if Archi.splitlong then SplitLong.longofint e else - match is_intconst e with - | Some n => longconst (Int64.repr (Int.signed n)) - | None => Eop Ocast32signed (e ::: Enil) - end. - -Definition longofintu (e: expr) := - if Archi.splitlong then SplitLong.longofintu e else - match is_intconst e with - | Some n => longconst (Int64.repr (Int.unsigned n)) - | None => Eop Ocast32unsigned (e ::: Enil) - end. - -(** ** Integer addition and pointer addition *) - -(** Original definition: -<< -Nondetfunction addlimm (n: int64) (e: expr) := - if Int64.eq n Int64.zero then e else - match e with - | Eop (Olongconst m) Enil => longconst (Int64.add n m) - | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) 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 (Oaddlimm n) (e ::: Enil) - end. ->> -*) - -Inductive addlimm_cases: forall (e: expr), Type := - | addlimm_case1: forall m, addlimm_cases (Eop (Olongconst m) Enil) - | addlimm_case2: forall s m, addlimm_cases (Eop (Oaddrsymbol s m) Enil) - | addlimm_case3: forall m, addlimm_cases (Eop (Oaddrstack m) Enil) - | addlimm_case4: forall m t, addlimm_cases (Eop (Oaddlimm m) (t ::: Enil)) - | addlimm_default: forall (e: expr), addlimm_cases e. - -Definition addlimm_match (e: expr) := - match e as zz1 return addlimm_cases zz1 with - | Eop (Olongconst m) Enil => addlimm_case1 m - | Eop (Oaddrsymbol s m) Enil => addlimm_case2 s m - | Eop (Oaddrstack m) Enil => addlimm_case3 m - | Eop (Oaddlimm m) (t ::: Enil) => addlimm_case4 m t - | e => addlimm_default e - end. - -Definition addlimm (n: int64) (e: expr) := - if Int64.eq n Int64.zero then e else match addlimm_match e with - | addlimm_case1 m => (* Eop (Olongconst m) Enil *) - longconst (Int64.add n m) - | addlimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) - Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil - | addlimm_case3 m => (* Eop (Oaddrstack m) Enil *) - Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil - | addlimm_case4 m t => (* Eop (Oaddlimm m) (t ::: Enil) *) - Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) - | addlimm_default e => - Eop (Oaddlimm n) (e ::: Enil) - end. - - -(** Original definition: -<< -Nondetfunction addl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.addl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) - | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) - | Eop (Oaddlimm n1) (t1:::Enil), t2 => - addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) - | t1, Eop (Oaddlimm n2) (t2:::Enil) => - addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) - | _, _ => Eop Oaddl (e1:::e2:::Enil) - end. ->> -*) - -Inductive addl_cases: forall (e1: expr) (e2: expr), Type := - | addl_case1: forall n1 t2, addl_cases (Eop (Olongconst n1) Enil) (t2) - | addl_case2: forall t1 n2, addl_cases (t1) (Eop (Olongconst n2) Enil) - | addl_case3: forall n1 t1 n2 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) - | addl_case4: forall n1 t1 n2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) - | addl_case5: forall n1 n2 t2, addl_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddlimm n2) (t2:::Enil)) - | addl_case6: forall n1 t1 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) - | addl_case7: forall t1 n2 t2, addl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) - | addl_default: forall (e1: expr) (e2: expr), addl_cases e1 e2. - -Definition addl_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return addl_cases zz1 zz2 with - | Eop (Olongconst n1) Enil, t2 => addl_case1 n1 t2 - | t1, Eop (Olongconst n2) Enil => addl_case2 t1 n2 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => addl_case3 n1 t1 n2 t2 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => addl_case4 n1 t1 n2 - | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => addl_case5 n1 n2 t2 - | Eop (Oaddlimm n1) (t1:::Enil), t2 => addl_case6 n1 t1 t2 - | t1, Eop (Oaddlimm n2) (t2:::Enil) => addl_case7 t1 n2 t2 - | e1, e2 => addl_default e1 e2 - end. - -Definition addl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.addl e1 e2 else match addl_match e1 e2 with - | addl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) - addlimm n1 t2 - | addl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - addlimm n2 t1 - | addl_case3 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) - addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) - | addl_case4 n1 t1 n2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) - | addl_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) *) - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) - | addl_case6 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) - addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) - | addl_case7 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) - addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) - | addl_default e1 e2 => - Eop Oaddl (e1:::e2:::Enil) - end. - - -(** ** Integer and pointer subtraction *) - -(** Original definition: -<< -Nondetfunction subl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.subl e1 e2 else - match e1, e2 with - | t1, Eop (Olongconst n2) Enil => - addlimm (Int64.neg n2) t1 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) - | Eop (Oaddlimm n1) (t1:::Enil), t2 => - addlimm n1 (Eop Osubl (t1:::t2:::Enil)) - | t1, Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) - | _, _ => Eop Osubl (e1:::e2:::Enil) - end. ->> -*) - -Inductive subl_cases: forall (e1: expr) (e2: expr), Type := - | subl_case1: forall t1 n2, subl_cases (t1) (Eop (Olongconst n2) Enil) - | subl_case2: forall n1 t1 n2 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) - | subl_case3: forall n1 t1 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) - | subl_case4: forall t1 n2 t2, subl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) - | subl_default: forall (e1: expr) (e2: expr), subl_cases e1 e2. - -Definition subl_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return subl_cases zz1 zz2 with - | t1, Eop (Olongconst n2) Enil => subl_case1 t1 n2 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => subl_case2 n1 t1 n2 t2 - | Eop (Oaddlimm n1) (t1:::Enil), t2 => subl_case3 n1 t1 t2 - | t1, Eop (Oaddlimm n2) (t2:::Enil) => subl_case4 t1 n2 t2 - | e1, e2 => subl_default e1 e2 - end. - -Definition subl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.subl e1 e2 else match subl_match e1 e2 with - | subl_case1 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - addlimm (Int64.neg n2) t1 - | subl_case2 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) - addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) - | subl_case3 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) - addlimm n1 (Eop Osubl (t1:::t2:::Enil)) - | subl_case4 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) - addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) - | subl_default e1 e2 => - Eop Osubl (e1:::e2:::Enil) - end. - - -Definition negl (e: expr) := - if Archi.splitlong then SplitLong.negl e else - match is_longconst e with - | Some n => longconst (Int64.neg n) - | None => Eop Onegl (e ::: Enil) - end. - -(** ** Immediate shifts *) - -(** Original definition: -<< -Nondetfunction shllimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shllimm e1 n else - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int64.iwordsize') then - Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shl' n1 n) - | Eop (Oshllimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshllimm n) (e1:::Enil) - | _ => - Eop (Oshllimm n) (e1:::Enil) - end. ->> -*) - -Inductive shllimm_cases: forall (e1: expr) , Type := - | shllimm_case1: forall n1, shllimm_cases (Eop (Olongconst n1) Enil) - | shllimm_case2: forall n1 t1, shllimm_cases (Eop (Oshllimm n1) (t1:::Enil)) - | shllimm_default: forall (e1: expr) , shllimm_cases e1. - -Definition shllimm_match (e1: expr) := - match e1 as zz1 return shllimm_cases zz1 with - | Eop (Olongconst n1) Enil => shllimm_case1 n1 - | Eop (Oshllimm n1) (t1:::Enil) => shllimm_case2 n1 t1 - | e1 => shllimm_default e1 - end. - -Definition shllimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shllimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shllimm_match e1 with - | shllimm_case1 n1 => (* Eop (Olongconst n1) Enil *) - longconst (Int64.shl' n1 n) - | shllimm_case2 n1 t1 => (* Eop (Oshllimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) else Eop (Oshllimm n) (e1:::Enil) - | shllimm_default e1 => - Eop (Oshllimm n) (e1:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shrluimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrluimm e1 n else - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int64.iwordsize') then - Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shru' n1 n) - | Eop (Oshrluimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrluimm n) (e1:::Enil) - | _ => - Eop (Oshrluimm n) (e1:::Enil) - end. ->> -*) - -Inductive shrluimm_cases: forall (e1: expr) , Type := - | shrluimm_case1: forall n1, shrluimm_cases (Eop (Olongconst n1) Enil) - | shrluimm_case2: forall n1 t1, shrluimm_cases (Eop (Oshrluimm n1) (t1:::Enil)) - | shrluimm_default: forall (e1: expr) , shrluimm_cases e1. - -Definition shrluimm_match (e1: expr) := - match e1 as zz1 return shrluimm_cases zz1 with - | Eop (Olongconst n1) Enil => shrluimm_case1 n1 - | Eop (Oshrluimm n1) (t1:::Enil) => shrluimm_case2 n1 t1 - | e1 => shrluimm_default e1 - end. - -Definition shrluimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrluimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) else match shrluimm_match e1 with - | shrluimm_case1 n1 => (* Eop (Olongconst n1) Enil *) - longconst (Int64.shru' n1 n) - | shrluimm_case2 n1 t1 => (* Eop (Oshrluimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil) - | shrluimm_default e1 => - Eop (Oshrluimm n) (e1:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shrlimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrlimm e1 n else - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int64.iwordsize') then - Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shr' n1 n) - | Eop (Oshrlimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrlimm n) (e1:::Enil) - | _ => - Eop (Oshrlimm n) (e1:::Enil) - end. ->> -*) - -Inductive shrlimm_cases: forall (e1: expr) , Type := - | shrlimm_case1: forall n1, shrlimm_cases (Eop (Olongconst n1) Enil) - | shrlimm_case2: forall n1 t1, shrlimm_cases (Eop (Oshrlimm n1) (t1:::Enil)) - | shrlimm_default: forall (e1: expr) , shrlimm_cases e1. - -Definition shrlimm_match (e1: expr) := - match e1 as zz1 return shrlimm_cases zz1 with - | Eop (Olongconst n1) Enil => shrlimm_case1 n1 - | Eop (Oshrlimm n1) (t1:::Enil) => shrlimm_case2 n1 t1 - | e1 => shrlimm_default e1 - end. - -Definition shrlimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrlimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) else match shrlimm_match e1 with - | shrlimm_case1 n1 => (* Eop (Olongconst n1) Enil *) - longconst (Int64.shr' n1 n) - | shrlimm_case2 n1 t1 => (* Eop (Oshrlimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil) - | shrlimm_default e1 => - Eop (Oshrlimm n) (e1:::Enil) - end. - - -(** ** General shifts *) - -Definition shll (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shll e1 e2 else - match is_intconst e2 with - | Some n2 => shllimm e1 n2 - | None => Eop Oshll (e1:::e2:::Enil) - end. - -Definition shrl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shrl e1 e2 else - match is_intconst e2 with - | Some n2 => shrlimm e1 n2 - | None => Eop Oshrl (e1:::e2:::Enil) - end. - -Definition shrlu (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shrlu e1 e2 else - match is_intconst e2 with - | Some n2 => shrluimm e1 n2 - | _ => Eop Oshrlu (e1:::e2:::Enil) - end. - -(** ** Integer multiply *) - -Definition mullimm_base (n1: int64) (e2: expr) := - match Int64.one_bits' n1 with - | i :: nil => - shllimm e2 i - | i :: j :: nil => - Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) - | _ => - Eop Omull (e2 ::: longconst n1 ::: Enil) - end. - -(** Original definition: -<< -Nondetfunction mullimm (n1: int64) (e2: expr) := - if Archi.splitlong then SplitLong.mullimm n1 e2 - else if Int64.eq n1 Int64.zero then longconst Int64.zero - else if Int64.eq n1 Int64.one then e2 - else match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) - | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) - | _ => mullimm_base n1 e2 - end. ->> -*) - -Inductive mullimm_cases: forall (e2: expr), Type := - | mullimm_case1: forall n2, mullimm_cases (Eop (Olongconst n2) Enil) - | mullimm_case2: forall n2 t2, mullimm_cases (Eop (Oaddlimm n2) (t2:::Enil)) - | mullimm_default: forall (e2: expr), mullimm_cases e2. - -Definition mullimm_match (e2: expr) := - match e2 as zz1 return mullimm_cases zz1 with - | Eop (Olongconst n2) Enil => mullimm_case1 n2 - | Eop (Oaddlimm n2) (t2:::Enil) => mullimm_case2 n2 t2 - | e2 => mullimm_default e2 - end. - -Definition mullimm (n1: int64) (e2: expr) := - if Archi.splitlong then SplitLong.mullimm n1 e2 else if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.one then e2 else match mullimm_match e2 with - | mullimm_case1 n2 => (* Eop (Olongconst n2) Enil *) - longconst (Int64.mul n1 n2) - | mullimm_case2 n2 t2 => (* Eop (Oaddlimm n2) (t2:::Enil) *) - addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) - | mullimm_default e2 => - mullimm_base n1 e2 - end. - - -(** Original definition: -<< -Nondetfunction mull (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.mull e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 - | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 - | _, _ => Eop Omull (e1:::e2:::Enil) - end. ->> -*) - -Inductive mull_cases: forall (e1: expr) (e2: expr), Type := - | mull_case1: forall n1 t2, mull_cases (Eop (Olongconst n1) Enil) (t2) - | mull_case2: forall t1 n2, mull_cases (t1) (Eop (Olongconst n2) Enil) - | mull_default: forall (e1: expr) (e2: expr), mull_cases e1 e2. - -Definition mull_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return mull_cases zz1 zz2 with - | Eop (Olongconst n1) Enil, t2 => mull_case1 n1 t2 - | t1, Eop (Olongconst n2) Enil => mull_case2 t1 n2 - | e1, e2 => mull_default e1 e2 - end. - -Definition mull (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.mull e1 e2 else match mull_match e1 e2 with - | mull_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) - mullimm n1 t2 - | mull_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - mullimm n2 t1 - | mull_default e1 e2 => - Eop Omull (e1:::e2:::Enil) - end. - - -Definition mullhu (e1: expr) (n2: int64) := - if Archi.splitlong then SplitLong.mullhu e1 n2 else - Eop Omullhu (e1 ::: longconst n2 ::: Enil). - -Definition mullhs (e1: expr) (n2: int64) := - if Archi.splitlong then SplitLong.mullhs e1 n2 else - Eop Omullhs (e1 ::: longconst n2 ::: Enil). - -(** ** Bitwise and, or, xor *) - -(** Original definition: -<< -Nondetfunction andlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then longconst Int64.zero else - if Int64.eq n1 Int64.mone then e2 else - match e2 with - | Eop (Olongconst n2) Enil => - longconst (Int64.and n1 n2) - | Eop (Oandlimm n2) (t2:::Enil) => - Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) - | _ => - Eop (Oandlimm n1) (e2:::Enil) - end. ->> -*) - -Inductive andlimm_cases: forall (e2: expr), Type := - | andlimm_case1: forall n2, andlimm_cases (Eop (Olongconst n2) Enil) - | andlimm_case2: forall n2 t2, andlimm_cases (Eop (Oandlimm n2) (t2:::Enil)) - | andlimm_default: forall (e2: expr), andlimm_cases e2. - -Definition andlimm_match (e2: expr) := - match e2 as zz1 return andlimm_cases zz1 with - | Eop (Olongconst n2) Enil => andlimm_case1 n2 - | Eop (Oandlimm n2) (t2:::Enil) => andlimm_case2 n2 t2 - | e2 => andlimm_default e2 - end. - -Definition andlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.mone then e2 else match andlimm_match e2 with - | andlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) - longconst (Int64.and n1 n2) - | andlimm_case2 n2 t2 => (* Eop (Oandlimm n2) (t2:::Enil) *) - Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) - | andlimm_default e2 => - Eop (Oandlimm n1) (e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction andl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.andl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 - | _, _ => Eop Oandl (e1:::e2:::Enil) - end. ->> -*) - -Inductive andl_cases: forall (e1: expr) (e2: expr), Type := - | andl_case1: forall n1 t2, andl_cases (Eop (Olongconst n1) Enil) (t2) - | andl_case2: forall t1 n2, andl_cases (t1) (Eop (Olongconst n2) Enil) - | andl_default: forall (e1: expr) (e2: expr), andl_cases e1 e2. - -Definition andl_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return andl_cases zz1 zz2 with - | Eop (Olongconst n1) Enil, t2 => andl_case1 n1 t2 - | t1, Eop (Olongconst n2) Enil => andl_case2 t1 n2 - | e1, e2 => andl_default e1 e2 - end. - -Definition andl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.andl e1 e2 else match andl_match e1 e2 with - | andl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) - andlimm n1 t2 - | andl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - andlimm n2 t1 - | andl_default e1 e2 => - Eop Oandl (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction orlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else - if Int64.eq n1 Int64.mone then longconst Int64.mone else - match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) - | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) - | _ => Eop (Oorlimm n1) (e2:::Enil) - end. ->> -*) - -Inductive orlimm_cases: forall (e2: expr), Type := - | orlimm_case1: forall n2, orlimm_cases (Eop (Olongconst n2) Enil) - | orlimm_case2: forall n2 t2, orlimm_cases (Eop (Oorlimm n2) (t2:::Enil)) - | orlimm_default: forall (e2: expr), orlimm_cases e2. - -Definition orlimm_match (e2: expr) := - match e2 as zz1 return orlimm_cases zz1 with - | Eop (Olongconst n2) Enil => orlimm_case1 n2 - | Eop (Oorlimm n2) (t2:::Enil) => orlimm_case2 n2 t2 - | e2 => orlimm_default e2 - end. - -Definition orlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else if Int64.eq n1 Int64.mone then longconst Int64.mone else match orlimm_match e2 with - | orlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) - longconst (Int64.or n1 n2) - | orlimm_case2 n2 t2 => (* Eop (Oorlimm n2) (t2:::Enil) *) - Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) - | orlimm_default e2 => - Eop (Oorlimm n1) (e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction orl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.orl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 - | _, _ => Eop Oorl (e1:::e2:::Enil) - end. ->> -*) - -Inductive orl_cases: forall (e1: expr) (e2: expr), Type := - | orl_case1: forall n1 t2, orl_cases (Eop (Olongconst n1) Enil) (t2) - | orl_case2: forall t1 n2, orl_cases (t1) (Eop (Olongconst n2) Enil) - | orl_default: forall (e1: expr) (e2: expr), orl_cases e1 e2. - -Definition orl_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return orl_cases zz1 zz2 with - | Eop (Olongconst n1) Enil, t2 => orl_case1 n1 t2 - | t1, Eop (Olongconst n2) Enil => orl_case2 t1 n2 - | e1, e2 => orl_default e1 e2 - end. - -Definition orl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.orl e1 e2 else match orl_match e1 e2 with - | orl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) - orlimm n1 t2 - | orl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - orlimm n2 t1 - | orl_default e1 e2 => - Eop Oorl (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction xorlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else - match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) - | Eop (Oxorlimm n2) (t2:::Enil) => - let n := Int64.xor n1 n2 in - if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) - | _ => Eop (Oxorlimm n1) (e2:::Enil) - end. ->> -*) - -Inductive xorlimm_cases: forall (e2: expr), Type := - | xorlimm_case1: forall n2, xorlimm_cases (Eop (Olongconst n2) Enil) - | xorlimm_case2: forall n2 t2, xorlimm_cases (Eop (Oxorlimm n2) (t2:::Enil)) - | xorlimm_default: forall (e2: expr), xorlimm_cases e2. - -Definition xorlimm_match (e2: expr) := - match e2 as zz1 return xorlimm_cases zz1 with - | Eop (Olongconst n2) Enil => xorlimm_case1 n2 - | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_case2 n2 t2 - | e2 => xorlimm_default e2 - end. - -Definition xorlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else match xorlimm_match e2 with - | xorlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) - longconst (Int64.xor n1 n2) - | xorlimm_case2 n2 t2 => (* Eop (Oxorlimm n2) (t2:::Enil) *) - let n := Int64.xor n1 n2 in if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) - | xorlimm_default e2 => - Eop (Oxorlimm n1) (e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction xorl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.xorl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 - | _, _ => Eop Oxorl (e1:::e2:::Enil) - end. ->> -*) - -Inductive xorl_cases: forall (e1: expr) (e2: expr), Type := - | xorl_case1: forall n1 t2, xorl_cases (Eop (Olongconst n1) Enil) (t2) - | xorl_case2: forall t1 n2, xorl_cases (t1) (Eop (Olongconst n2) Enil) - | xorl_default: forall (e1: expr) (e2: expr), xorl_cases e1 e2. - -Definition xorl_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return xorl_cases zz1 zz2 with - | Eop (Olongconst n1) Enil, t2 => xorl_case1 n1 t2 - | t1, Eop (Olongconst n2) Enil => xorl_case2 t1 n2 - | e1, e2 => xorl_default e1 e2 - end. - -Definition xorl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.xorl e1 e2 else match xorl_match e1 e2 with - | xorl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) - xorlimm n1 t2 - | xorl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) - xorlimm n2 t1 - | xorl_default e1 e2 => - Eop Oxorl (e1:::e2:::Enil) - end. - - -(** ** Integer logical negation *) - -Definition notl (e: expr) := - if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. - -(** ** Integer division and modulus *) - -Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. -Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. -Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. -Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. - -Definition shrxlimm (e: expr) (n: int) := - if Archi.splitlong then SplitLong.shrxlimm e n else - if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). - -(** ** Comparisons *) - -Definition cmplu (c: comparison) (e1 e2: expr) := - if Archi.splitlong then SplitLong.cmplu c e1 e2 else - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => - Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil - | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) - | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) - | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) - end. - -Definition cmpl (c: comparison) (e1 e2: expr) := - if Archi.splitlong then SplitLong.cmpl c e1 e2 else - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => - Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil - | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) - | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) - | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) - end. - -(** ** Floating-point conversions *) - -Definition longoffloat (e: expr) := - if Archi.splitlong then SplitLong.longoffloat e else - Eop Olongoffloat (e:::Enil). - -Definition longuoffloat (e: expr) := - if Archi.splitlong then SplitLong.longuoffloat e else - Eop Olonguoffloat (e:::Enil). - -Definition floatoflong (e: expr) := - if Archi.splitlong then SplitLong.floatoflong e else - Eop Ofloatoflong (e:::Enil). - -Definition floatoflongu (e: expr) := - if Archi.splitlong then SplitLong.floatoflongu e else - Eop Ofloatoflongu (e:::Enil). - -(* FIXME - normally we can have it natively, but in practice it requires proving that we can do Fwidenlwd + fixedd.rz.. To do later *) -Definition longofsingle (e: expr) := SplitLong.longofsingle e. -(* - if Archi.splitlong then SplitLong.longofsingle e else - Eop Olongofsingle (e:::Enil). -*) - -Definition longuofsingle (e: expr) := SplitLong.longuofsingle e. -(* - if Archi.splitlong then SplitLong.longuofsingle e else - Eop Olonguofsingle (e:::Enil). -*) - -Definition singleoflong (e: expr) := SplitLong.singleoflong e. -(* - if Archi.splitlong then SplitLong.singleoflong e else - Eop Osingleoflong (e:::Enil). -*) - -Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. -(* - if Archi.splitlong then SplitLong.singleoflongu e else - Eop Osingleoflongu (e:::Enil). -*) - -End SELECT. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index a3aefb15..5e94fbb5 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -341,29 +341,13 @@ Definition floatoflongu (e: expr) := if Archi.splitlong then SplitLong.floatoflongu e else Eop Ofloatoflongu (e:::Enil). -(* FIXME - normally we can have it natively, but in practice it requires proving that we can do Fwidenlwd + fixedd.rz.. To do later *) +(* SplitLong.longofsingle splits the operation into (longoffloat (floatofsingle e)) *) Definition longofsingle (e: expr) := SplitLong.longofsingle e. -(* - if Archi.splitlong then SplitLong.longofsingle e else - Eop Olongofsingle (e:::Enil). -*) Definition longuofsingle (e: expr) := SplitLong.longuofsingle e. -(* - if Archi.splitlong then SplitLong.longuofsingle e else - Eop Olonguofsingle (e:::Enil). -*) Definition singleoflong (e: expr) := SplitLong.singleoflong e. -(* - if Archi.splitlong then SplitLong.singleoflong e else - Eop Osingleoflong (e:::Enil). -*) Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. -(* - if Archi.splitlong then SplitLong.singleoflongu e else - Eop Osingleoflongu (e:::Enil). -*) End SELECT. -- cgit From 456787ab7f394e15b3b0481f4d4178ebf04259c7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 11:00:56 +0100 Subject: instruction rotate --- mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 2 ++ 2 files changed, 3 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 117bbcb4..28d60fa5 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -54,6 +54,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshl | Oshr | Oshru => op2 (default nv) | Oshlimm n => op1 (shlimm nv n) | Oshrimm n => op1 (shrimm nv n) + | Ororimm n => op1 (ror nv n) | Oshruimm n => op1 (shruimm nv n) | Oshrximm n => op1 (default nv) | Omakelong => op2 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 74101f53..e91c6ae1 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -89,6 +89,7 @@ Inductive operation : Type := | Oshru (**r [rd = r1 >> r2] (unsigned) *) | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Ororimm (n: int) (**r rotate right immediate *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -414,6 +415,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshru => (Tint :: Tint :: nil, Tint) | Oshruimm _ => (Tint :: nil, Tint) | Oshrximm _ => (Tint :: nil, Tint) + | Ororimm _ => (Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) | Ohighlong => (Tlong :: nil, Tint) -- cgit From 9526f710a65f9009822240bf2b47e9bc6c07cf19 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 12:29:17 +0100 Subject: ValueAOp rotate 32-bit --- mppa_k1c/ValueAOp.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 5670b5fe..26a49135 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -73,6 +73,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshlimm n, v1::nil => shl v1 (I n) | Oshr, v1::v2::nil => shr v1 v2 | Oshrimm n, v1::nil => shr v1 (I n) + | Ororimm n, v1::nil => ror v1 (I n) | Oshru, v1::v2::nil => shru v1 v2 | Oshruimm n, v1::nil => shru v1 (I n) | Oshrximm n, v1::nil => shrx v1 (I n) -- cgit From c8f019b509c20bea50330761c5aa0a95e17c6e65 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 12:56:41 +0100 Subject: some more progress on rotate --- mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 5 +++++ 2 files changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 28d60fa5..5f8648d3 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -155,6 +155,7 @@ Proof. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. +- apply ror_sound; auto. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index e91c6ae1..3a006fb2 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -256,6 +256,7 @@ Definition eval_operation | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) + | Ororimm n, v1 :: nil => Some (Val.ror v1 (Vint n)) | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) @@ -568,6 +569,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... (* shrx *) - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + (* shrimm *) + - destruct v0; simpl... (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -1031,6 +1034,8 @@ Proof. (* shrx *) - inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + (* rorimm *) + - inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. -- cgit From 29d5c75e65a7fddf88bbd8c1946e700eed09dd23 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 13:48:08 +0100 Subject: select rotate ops 32-bit --- mppa_k1c/SelectOp.v | 22 ++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 14 ++++++++++++++ mppa_k1c/SelectOpproof.v | 40 ++++++++++++++++++++++++++++++++++++++-- 3 files changed, 74 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index c42f0340..fb7f476f 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -591,12 +591,26 @@ Definition orimm (n1: int) (e2: expr) := end. +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + (** Original definition: << Nondetfunction or (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. >> @@ -605,12 +619,16 @@ Nondetfunction or (e1: expr) (e2: expr) := Inductive or_cases: forall (e1: expr) (e2: expr), Type := | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) + | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) + | or_case4: forall n2 t2 n1 t1, or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. Definition or_match (e1: expr) (e2: expr) := match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => or_case3 n1 t1 n2 t2 + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => or_case4 n2 t2 n1 t1 | e1, e2 => or_default e1 e2 end. @@ -620,6 +638,10 @@ Definition or (e1: expr) (e2: expr) := orimm n1 t2 | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) orimm n2 t1 + | or_case3 n1 t1 n2 t2 => (* Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) *) + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) + | or_case4 n2 t2 n1 t1 => (* Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) *) + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) | or_default e1 e2 => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index bb8af2ed..14753871 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -235,10 +235,24 @@ Nondetfunction orimm (n1: int) (e2: expr) := | _ => Eop (Oorimm n1) (e2:::Enil) end. +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + Nondetfunction or (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index e7577fb5..c5f05dcf 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -452,12 +452,48 @@ Proof. - TrivialExists. Qed. + +Remark eval_same_expr: + forall a1 a2 le v1 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + a1 = a2 /\ v1 = v2. +Proof. + intros until v2. + destruct a1; simpl; try (intros; discriminate). + destruct a2; simpl; try (intros; discriminate). + case (ident_eq i i0); intros. + subst i0. inversion H0. inversion H1. split. auto. congruence. + discriminate. +Qed. + Theorem eval_or: binary_constructor_sound or Val.or. Proof. - red; intros until y; unfold or; case (or_match a b); intros; InvEval. + unfold or; red; intros. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oor (a:::b:::Enil)) v /\ Val.lessdef (Val.or x y) v) by TrivialExists. + assert (ROR: forall v n1 n2, + Int.add n1 n2 = Int.iwordsize -> + Val.lessdef (Val.or (Val.shl v (Vint n1)) (Val.shru v (Vint n2))) + (Val.ror v (Vint n2))). + { intros. destruct v; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) eqn:N1; auto. + destruct (Int.ltu n2 Int.iwordsize) eqn:N2; auto. + simpl. rewrite <- Int.or_ror; auto. } + + destruct (or_match a b); InvEval. + - rewrite Val.or_commut. apply eval_orimm; auto. - apply eval_orimm; auto. - - TrivialExists. + - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v0 (Vint n2)); split. EvalOp. apply ROR; auto. + - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. + - apply DEFAULT. Qed. Theorem eval_xorimm: -- cgit From 983cab07c39a7bed288e9e953d95ffe990783825 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 14:07:07 +0100 Subject: 32-bit rotate finished --- mppa_k1c/Asm.v | 3 ++- mppa_k1c/Asmblock.v | 3 ++- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 5 ++++- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++--- mppa_k1c/TargetPrinter.ml | 3 +++ 6 files changed, 17 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 31bc855d..5ed54a2b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -171,7 +171,7 @@ Inductive instruction : Type := | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) | 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 *) | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) @@ -291,6 +291,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmblock.Proriw rd rs imm => Proriw rd rs imm | PArithRRI32 Asmblock.Psllil rd rs imm => Psllil rd rs imm | PArithRRI32 Asmblock.Psrlil rd rs imm => Psrlil rd rs imm | PArithRRI32 Asmblock.Psrail rd rs imm => Psrail rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 621ed8a7..883cfb94 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -372,7 +372,7 @@ Inductive arith_name_rri32 : Type := | Psraiw (**r shift right arithmetic imm word *) | Psrliw (**r shift right logical imm word *) | Pslliw (**r shift left logical imm word *) - + | Proriw (**r rotate right imm word *) | Psllil (**r shift left logical immediate long *) | Psrlil (**r shift right logical immediate long *) | Psrail (**r shift right arithmetic immediate long *) @@ -1125,6 +1125,7 @@ Definition arith_eval_rri32 n v i := | Psraiw => Val.shr v (Vint i) | Psrliw => Val.shru v (Vint i) | Pslliw => Val.shl v (Vint i) + | Proriw => Val.ror v (Vint i) | Psllil => Val.shll v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c6052337..19fca6c1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1332,6 +1332,7 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := | Psraiw => "Psraiw" | Psrliw => "Psrliw" | Pslliw => "Pslliw" + | Proriw => "Proriw" | Psllil => "Psllil" | Psrlil => "Psrlil" | Psrail => "Psrail" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 1c176538..26b1c6c1 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -471,7 +471,10 @@ Definition transl_op Psrliw RTMP RTMP (Int.sub Int.iwordsize n) ::i Paddw RTMP rs RTMP ::i Psraiw rd RTMP n ::i k) - + | Ororimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Proriw rd rs n ::i k) + (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9700776c..97108a90 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -91,6 +91,7 @@ let arith_rri32_str = function | Psraiw -> "Psraiw" | Psrliw -> "Psrliw" | Pslliw -> "Pslliw" + | Proriw -> "Proriw" | Psllil -> "Psllil" | Psrlil -> "Psrlil" | Psrail -> "Psrail" @@ -375,7 +376,7 @@ let lsu_data_y : int array = let resmap = fun r -> match r with type real_instruction = (* ALU *) - | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Nop | Sxwd | Zxwd (* LSU *) @@ -409,6 +410,7 @@ let ab_inst_to_real = function | "Psrlw" | "Psrliw" -> Srlw | "Psrll" | "Psrlil" -> Srld | "Psllw" | "Pslliw" -> Sllw + | "Proriw" -> Rorw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pxorl" | "Pxoril" -> Xord @@ -504,7 +506,7 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Sllw | Rorw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> @@ -523,7 +525,7 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Rorw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 70d9ff6c..810808c2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -430,6 +430,9 @@ module Target (*: TARGET*) = fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pslliw (rd, rs, imm) -> fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Proriw (rd, rs, imm) -> + fprintf oc " rorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psllil (rd, rs, imm) -> fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrlil (rd, rs, imm) -> -- cgit From 1b1577c372c71a11831feb043e3b050deb60ba99 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 14:26:32 +0100 Subject: fix problem with ALU reservation tables --- mppa_k1c/PostpassSchedulingOracle.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 97108a90..4627dd09 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -506,7 +506,9 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Sllw | Rorw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + (* TODO: check *) + | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> -- cgit From 0d66eae95a8905ff985cd4738808fc93215a4904 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 16:16:42 +0100 Subject: nand debut --- mppa_k1c/NeedOp.v | 4 ++++ mppa_k1c/Op.v | 12 ++++++++++++ mppa_k1c/ValueAOp.v | 2 ++ 3 files changed, 18 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 5f8648d3..c5d9e58f 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -47,6 +47,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) | Oand => op2 (bitwise nv) | Oandimm n => op1 (andimm nv n) + | Onand => op2 (bitwise nv) + | Onandimm n => op1 (andimm nv n) | Oor => op2 (bitwise nv) | Oorimm n => op1 (orimm nv n) | Oxor => op2 (bitwise nv) @@ -148,6 +150,8 @@ Proof. - apply mul_sound; auto. - apply and_sound; auto. - apply andimm_sound; auto. +- apply notint_sound; apply and_sound; auto. +- apply notint_sound; apply andimm_sound; auto. - apply or_sound; auto. - apply orimm_sound; auto. - apply xor_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 3a006fb2..8c5f01cd 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -78,6 +78,8 @@ Inductive operation : Type := | Omodu (**r [rd = r1 % r2] (unsigned) *) | Oand (**r [rd = r1 & r2] *) | Oandimm (n: int) (**r [rd = r1 & n] *) + | Onand (**r [rd = ~(r1 & r2)] *) + | Onandimm (n: int) (**r [rd = ~(r1 & n)] *) | Oor (**r [rd = r1 | r2] *) | Oorimm (n: int) (**r [rd = r1 | n] *) | Oxor (**r [rd = r1 ^ r2] *) @@ -248,6 +250,8 @@ Definition eval_operation | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Onand, v1 :: v2 :: nil => Some (Val.notint (Val.and v1 v2)) + | Onandimm n, v1 :: nil => Some (Val.notint (Val.and v1 (Vint n))) | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) @@ -405,6 +409,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omodu => (Tint :: Tint :: nil, Tint) | Oand => (Tint :: Tint :: nil, Tint) | Oandimm _ => (Tint :: nil, Tint) + | Onand => (Tint :: Tint :: nil, Tint) + | Onandimm _ => (Tint :: nil, Tint) | Oor => (Tint :: Tint :: nil, Tint) | Oorimm _ => (Tint :: nil, Tint) | Oxor => (Tint :: Tint :: nil, Tint) @@ -552,6 +558,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* and, andimm *) - destruct v0; destruct v1... - destruct v0... + (* nand, nandimm *) + - destruct v0; destruct v1... + - destruct v0... (* or, orimm *) - destruct v0; destruct v1... - destruct v0... @@ -1016,6 +1025,9 @@ Proof. (* and, andimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* nand, nandimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* or, orimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 26a49135..a78857b3 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -65,6 +65,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omodu, v1::v2::nil => modu v1 v2 | Oand, v1::v2::nil => and v1 v2 | Oandimm n, v1::nil => and v1 (I n) + | Onand, v1::v2::nil => notint (and v1 v2) + | Onandimm n, v1::nil => notint (and v1 (I n)) | Oor, v1::v2::nil => or v1 v2 | Oorimm n, v1::nil => or v1 (I n) | Oxor, v1::v2::nil => xor v1 v2 -- cgit From 33648f1fbee9442190bb85fae1192b7b119daf81 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 16:48:54 +0100 Subject: some more nand --- mppa_k1c/SelectOp.v | 34 +++++++++++++++++++++++++++++++++- mppa_k1c/SelectOp.vp | 7 ++++++- mppa_k1c/SelectOpproof.v | 7 ++++++- 3 files changed, 45 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index fb7f476f..4d3d5ad0 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -720,7 +720,39 @@ Definition xor (e1: expr) (e2: expr) := (** ** Integer logical negation *) -Definition notint (e: expr) := xorimm Int.mone e. +(** Original definition: +<< +Nondetfunction notint (e: expr) := + match e with + | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) + | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) + | _ => xorimm Int.mone e + end. +>> +*) + +Inductive notint_cases: forall (e: expr), Type := + | notint_case1: forall e1 e2, notint_cases (Eop Oand (e1:::e2:::Enil)) + | notint_case2: forall n e1, notint_cases (Eop (Oandimm n) (e1:::Enil)) + | notint_default: forall (e: expr), notint_cases e. + +Definition notint_match (e: expr) := + match e as zz1 return notint_cases zz1 with + | Eop Oand (e1:::e2:::Enil) => notint_case1 e1 e2 + | Eop (Oandimm n) (e1:::Enil) => notint_case2 n e1 + | e => notint_default e + end. + +Definition notint (e: expr) := + match notint_match e with + | notint_case1 e1 e2 => (* Eop Oand (e1:::e2:::Enil) *) + Eop Onand (e1:::e2:::Enil) + | notint_case2 n e1 => (* Eop (Oandimm n) (e1:::Enil) *) + Eop (Onandimm n) (e1:::Enil) + | notint_default e => + xorimm Int.mone e + end. + (** ** Integer division and modulus *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 14753871..4b64e495 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -275,7 +275,12 @@ Nondetfunction xor (e1: expr) (e2: expr) := (** ** Integer logical negation *) -Definition notint (e: expr) := xorimm Int.mone e. +Nondetfunction notint (e: expr) := + match e with + | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) + | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) + | _ => xorimm Int.mone e + end. (** ** Integer division and modulus *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index c5f05dcf..c14a622a 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -524,7 +524,12 @@ Qed. Theorem eval_notint: unary_constructor_sound notint Val.notint. Proof. - unfold notint; red; intros. rewrite Val.not_xor. apply eval_xorimm; auto. + assert (forall v, Val.lessdef (Val.notint (Val.notint v)) v). + destruct v; simpl; auto. rewrite Int.not_involutive; auto. + unfold notint; red; intros until x; case (notint_match a); intros; InvEval. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - apply eval_xorimm; assumption. Qed. Theorem eval_divs_base: -- cgit From 8155320553564674b7481b325c33845439b46b95 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 17:06:16 +0100 Subject: nand is implemented --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmblock.v | 4 ++++ mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/Asmblockgen.v | 7 +++++++ mppa_k1c/PostpassSchedulingOracle.ml | 9 +++++++-- mppa_k1c/TargetPrinter.ml | 4 ++++ 6 files changed, 28 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 5ed54a2b..ee3fd198 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -138,6 +138,7 @@ Inductive instruction : Type := | 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 and word *) | Porw (rd rs1 rs2: ireg) (**r or word *) | Pxorw (rd rs1 rs2: ireg) (**r xor word *) | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) @@ -166,6 +167,7 @@ Inductive instruction : Type := | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r and imm word *) | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) @@ -259,6 +261,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 | PArithRRR Asmblock.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmblock.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2 | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 @@ -286,6 +289,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmblock.Pnandiw rd rs imm => Pnandiw rd rs imm | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 883cfb94..ca9a96a5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -338,6 +338,7 @@ Inductive arith_name_rrr : Type := | Psubw (**r sub word *) | Pmulw (**r mul word *) | Pandw (**r and word *) + | Pnandw (**r and word *) | Porw (**r or word *) | Pxorw (**r xor word *) | Psraw (**r shift right arithmetic word *) @@ -367,6 +368,7 @@ Inductive arith_name_rri32 : Type := | Paddiw (**r add imm word *) | Pandiw (**r and imm word *) + | Pnandiw (**r and imm word *) | Poriw (**r or imm word *) | Pxoriw (**r xor imm word *) | Psraiw (**r shift right arithmetic imm word *) @@ -1091,6 +1093,7 @@ Definition arith_eval_rrr n v1 v2 := | Psubw => Val.sub v1 v2 | Pmulw => Val.mul v1 v2 | Pandw => Val.and v1 v2 + | Pnandw => Val.notint (Val.and v1 v2) | Porw => Val.or v1 v2 | Pxorw => Val.xor v1 v2 | Psrlw => Val.shru v1 v2 @@ -1120,6 +1123,7 @@ Definition arith_eval_rri32 n v i := | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) | Pandiw => Val.and v (Vint i) + | Pnandiw => Val.notint(Val.and v (Vint i)) | Poriw => Val.or v (Vint i) | Pxoriw => Val.xor v (Vint i) | Psraiw => Val.shr v (Vint i) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 19fca6c1..499b0d66 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1300,6 +1300,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Psubw => "Psubw" | Pmulw => "Pmulw" | Pandw => "Pandw" + | Pnandw => "Pnandw" | Porw => "Porw" | Pxorw => "Pxorw" | Psraw => "Psraw" @@ -1327,6 +1328,7 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" | Pandiw => "Pandiw" + | Pnandiw => "Pnandiw" | Poriw => "Poriw" | Pxoriw => "Pxoriw" | Psraiw => "Psraiw" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 26b1c6c1..12dabd88 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -86,6 +86,7 @@ Definition opimm32 (op: arith_name_rrr) Definition addimm32 := opimm32 Paddw Paddiw. Definition andimm32 := opimm32 Pandw Pandiw. +Definition nandimm32 := opimm32 Pnandw Pnandiw. Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. (* @@ -434,6 +435,12 @@ Definition transl_op | Oandimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm32 rd rs n ::i k) + | Onand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnandw rd rs1 rs2 ::i k) + | Onandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nandimm32 rd rs n ::i k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 ::i k) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 4627dd09..791936f3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -61,6 +61,7 @@ let arith_rrr_str = function | Psubw -> "Psubw" | Pmulw -> "Pmulw" | Pandw -> "Pandw" + | Pnandw -> "Pnandw" | Porw -> "Porw" | Pxorw -> "Pxorw" | Psraw -> "Psraw" @@ -86,6 +87,7 @@ let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" | Pandiw -> "Pandiw" + | Pnandiw -> "Pnandiw" | Poriw -> "Poriw" | Pxoriw -> "Pxoriw" | Psraiw -> "Psraiw" @@ -378,6 +380,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord + | Nandw | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -394,6 +397,7 @@ let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd | "Pandw" | "Pandiw" -> Andw + | "Pnandw" | "Pnandiw" -> Nandw | "Pandl" | "Pandil" -> Andd | "Pcompw" | "Pcompiw" -> Compw | "Pcompl" | "Pcompil" -> Compd @@ -475,7 +479,7 @@ let rec_to_usage r = (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst in match real_inst with - | Addw | Andw | Orw | Sbfw | Xorw -> + | Addw | Andw | Nandw | Orw | Sbfw | Xorw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) @@ -527,7 +531,8 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw | Rorw + | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Rorw | Nandw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 810808c2..9ab09866 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -370,6 +370,8 @@ module Target (*: TARGET*) = fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnandw (rd, rs1, rs2) -> + fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porw (rd, rs1, rs2) -> fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> @@ -420,6 +422,8 @@ module Target (*: TARGET*) = fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnandiw (rd, rs, imm) -> + fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs coqint imm | Poriw (rd, rs, imm) -> fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pxoriw (rd, rs, imm) -> -- cgit From fb02f9116621a0bcb9bb2c334ad782fee5887d0e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 18:01:25 +0100 Subject: partial norw --- mppa_k1c/Asm.v | 8 ++++++-- mppa_k1c/Asmblock.v | 10 +++++++--- mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/PostpassSchedulingOracle.ml | 11 +++++++---- mppa_k1c/TargetPrinter.ml | 4 ++++ 5 files changed, 26 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index ee3fd198..3e4e4db7 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -138,8 +138,9 @@ Inductive instruction : Type := | 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 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 *) | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) @@ -167,8 +168,9 @@ Inductive instruction : Type := | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (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 *) | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) @@ -263,6 +265,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 | PArithRRR Asmblock.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmblock.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 @@ -291,6 +294,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm | PArithRRI32 Asmblock.Pnandiw rd rs imm => Pnandiw rd rs imm | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmblock.Pnoriw rd rs imm => Pnoriw rd rs imm | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ca9a96a5..66878a94 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -338,8 +338,9 @@ Inductive arith_name_rrr : Type := | Psubw (**r sub word *) | Pmulw (**r mul word *) | Pandw (**r and word *) - | Pnandw (**r and word *) + | Pnandw (**r nand word *) | Porw (**r or word *) + | Pnorw (**r nor word *) | Pxorw (**r xor word *) | Psraw (**r shift right arithmetic word *) | Psrlw (**r shift right logical word *) @@ -368,8 +369,9 @@ Inductive arith_name_rri32 : Type := | Paddiw (**r add imm word *) | Pandiw (**r and imm word *) - | Pnandiw (**r and imm word *) + | Pnandiw (**r nand imm word *) | Poriw (**r or imm word *) + | Pnoriw (**r nor imm word *) | Pxoriw (**r xor imm word *) | Psraiw (**r shift right arithmetic imm word *) | Psrliw (**r shift right logical imm word *) @@ -1095,6 +1097,7 @@ Definition arith_eval_rrr n v1 v2 := | Pandw => Val.and v1 v2 | Pnandw => Val.notint (Val.and v1 v2) | Porw => Val.or v1 v2 + | Pnorw => Val.notint (Val.or v1 v2) | Pxorw => Val.xor v1 v2 | Psrlw => Val.shru v1 v2 | Psraw => Val.shr v1 v2 @@ -1123,8 +1126,9 @@ Definition arith_eval_rri32 n v i := | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) | Pandiw => Val.and v (Vint i) - | Pnandiw => Val.notint(Val.and v (Vint i)) + | Pnandiw => Val.notint (Val.and v (Vint i)) | Poriw => Val.or v (Vint i) + | Pnoriw => Val.notint (Val.or v (Vint i)) | Pxoriw => Val.xor v (Vint i) | Psraiw => Val.shr v (Vint i) | Psrliw => Val.shru v (Vint i) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 499b0d66..0694c22f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1302,6 +1302,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pandw => "Pandw" | Pnandw => "Pnandw" | Porw => "Porw" + | Pnorw => "Pnorw" | Pxorw => "Pxorw" | Psraw => "Psraw" | Psrlw => "Psrlw" @@ -1330,6 +1331,7 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" | Poriw => "Poriw" + | Pnoriw => "Pnoriw" | Pxoriw => "Pxoriw" | Psraiw => "Psraiw" | Psrliw => "Psrliw" diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 791936f3..c674bf3e 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -63,6 +63,7 @@ let arith_rrr_str = function | Pandw -> "Pandw" | Pnandw -> "Pnandw" | Porw -> "Porw" + | Pnorw -> "Pnorw" | Pxorw -> "Pxorw" | Psraw -> "Psraw" | Psrlw -> "Psrlw" @@ -89,6 +90,7 @@ let arith_rri32_str = function | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" | Poriw -> "Poriw" + | Pnoriw -> "Pnoriw" | Pxoriw -> "Pxoriw" | Psraiw -> "Psraiw" | Psrliw -> "Psrliw" @@ -380,7 +382,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord - | Nandw + | Nandw | Norw | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -406,6 +408,7 @@ let ab_inst_to_real = function | "Pmulw" -> Mulw | "Pmull" -> Muld | "Porw" | "Poriw" -> Orw + | "Pnorw" | "Pnoriw" -> Norw | "Porl" | "Poril" -> Ord | "Psubw" | "Pnegw" -> Sbfw | "Psubl" | "Pnegl" -> Sbfd @@ -469,7 +472,7 @@ let ab_inst_to_real = function | "Pfmuld" -> Fmuld | "Pfmulw" -> Fmulw | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s - + exception InvalidEncoding let rec_to_usage r = @@ -479,7 +482,7 @@ let rec_to_usage r = (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst in match real_inst with - | Addw | Andw | Nandw | Orw | Sbfw | Xorw -> + | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) @@ -532,7 +535,7 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw - | Rorw | Nandw + | Rorw | Nandw | Norw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 9ab09866..07663074 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -374,6 +374,8 @@ module Target (*: TARGET*) = fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porw (rd, rs1, rs2) -> fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnorw (rd, rs1, rs2) -> + fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> @@ -426,6 +428,8 @@ module Target (*: TARGET*) = fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs coqint imm | Poriw (rd, rs, imm) -> fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnoriw (rd, rs, imm) -> + fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pxoriw (rd, rs, imm) -> fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> -- cgit From 4e3b46ca2a30abf520672f4b1a28f91f171f6e7e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 18:24:03 +0100 Subject: nor implemente --- mppa_k1c/Asmblockgen.v | 7 +++++++ mppa_k1c/NeedOp.v | 4 ++++ mppa_k1c/Op.v | 12 ++++++++++++ mppa_k1c/SelectOp.v | 10 ++++++++++ mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 2 ++ mppa_k1c/ValueAOp.v | 2 ++ 7 files changed, 39 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 12dabd88..9b9e9a12 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -88,6 +88,7 @@ Definition addimm32 := opimm32 Paddw Paddiw. Definition andimm32 := opimm32 Pandw Pandiw. Definition nandimm32 := opimm32 Pnandw Pnandiw. Definition orimm32 := opimm32 Porw Poriw. +Definition norimm32 := opimm32 Pnorw Pnoriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. (* Definition sltimm32 := opimm32 Psltw Psltiw. @@ -444,9 +445,15 @@ Definition transl_op | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 ::i k) + | Onor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnorw rd rs1 rs2 ::i k) | Oorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm32 rd rs n ::i k) + | Onorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (norimm32 rd rs n ::i k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorw rd rs1 rs2 ::i k) diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index c5d9e58f..3442e3c1 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -51,6 +51,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onandimm n => op1 (andimm nv n) | Oor => op2 (bitwise nv) | Oorimm n => op1 (orimm nv n) + | Onor => op2 (bitwise nv) + | Onorimm n => op1 (orimm nv n) | Oxor => op2 (bitwise nv) | Oxorimm n => op1 (bitwise nv) | Oshl | Oshr | Oshru => op2 (default nv) @@ -154,6 +156,8 @@ Proof. - apply notint_sound; apply andimm_sound; auto. - apply or_sound; auto. - apply orimm_sound; auto. +- apply notint_sound; apply or_sound; auto. +- apply notint_sound; apply orimm_sound; auto. - apply xor_sound; auto. - apply xor_sound; auto with na. - apply shlimm_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 8c5f01cd..275613bb 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -82,6 +82,8 @@ 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] *) | Oxor (**r [rd = r1 ^ r2] *) | Oxorimm (n: int) (**r [rd = r1 ^ n] *) | Oshl (**r [rd = r1 << r2] *) @@ -254,6 +256,8 @@ Definition eval_operation | Onandimm n, v1 :: nil => Some (Val.notint (Val.and v1 (Vint n))) | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Onor, v1 :: v2 :: nil => Some (Val.notint (Val.or v1 v2)) + | Onorimm n, v1 :: nil => Some (Val.notint (Val.or v1 (Vint n))) | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) @@ -413,6 +417,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Onandimm _ => (Tint :: nil, Tint) | Oor => (Tint :: Tint :: nil, Tint) | Oorimm _ => (Tint :: nil, Tint) + | Onor => (Tint :: Tint :: nil, Tint) + | Onorimm _ => (Tint :: nil, Tint) | Oxor => (Tint :: Tint :: nil, Tint) | Oxorimm _ => (Tint :: nil, Tint) | Oshl => (Tint :: Tint :: nil, Tint) @@ -564,6 +570,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* or, orimm *) - destruct v0; destruct v1... - destruct v0... + (* nor, norimm *) + - destruct v0; destruct v1... + - destruct v0... (* xor, xorimm *) - destruct v0; destruct v1... - destruct v0... @@ -1031,6 +1040,9 @@ Proof. (* or, orimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* nor, norimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* xor, xorimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index 4d3d5ad0..028c2eb1 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -726,6 +726,8 @@ Nondetfunction notint (e: expr) := match e with | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) + | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) + | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | _ => xorimm Int.mone e end. >> @@ -734,12 +736,16 @@ Nondetfunction notint (e: expr) := Inductive notint_cases: forall (e: expr), Type := | notint_case1: forall e1 e2, notint_cases (Eop Oand (e1:::e2:::Enil)) | notint_case2: forall n e1, notint_cases (Eop (Oandimm n) (e1:::Enil)) + | notint_case3: forall e1 e2, notint_cases (Eop Oor (e1:::e2:::Enil)) + | notint_case4: forall n e1, notint_cases (Eop (Oorimm n) (e1:::Enil)) | notint_default: forall (e: expr), notint_cases e. Definition notint_match (e: expr) := match e as zz1 return notint_cases zz1 with | Eop Oand (e1:::e2:::Enil) => notint_case1 e1 e2 | Eop (Oandimm n) (e1:::Enil) => notint_case2 n e1 + | Eop Oor (e1:::e2:::Enil) => notint_case3 e1 e2 + | Eop (Oorimm n) (e1:::Enil) => notint_case4 n e1 | e => notint_default e end. @@ -749,6 +755,10 @@ Definition notint (e: expr) := Eop Onand (e1:::e2:::Enil) | notint_case2 n e1 => (* Eop (Oandimm n) (e1:::Enil) *) Eop (Onandimm n) (e1:::Enil) + | notint_case3 e1 e2 => (* Eop Oor (e1:::e2:::Enil) *) + Eop Onor (e1:::e2:::Enil) + | notint_case4 n e1 => (* Eop (Oorimm n) (e1:::Enil) *) + Eop (Onorimm n) (e1:::Enil) | notint_default e => xorimm Int.mone e end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 4b64e495..3f806dda 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -279,6 +279,8 @@ Nondetfunction notint (e: expr) := match e with | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) + | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) + | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | _ => xorimm Int.mone e end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index c14a622a..59ea598a 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -529,6 +529,8 @@ Proof. unfold notint; red; intros until x; case (notint_match a); intros; InvEval. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. - apply eval_xorimm; assumption. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index a78857b3..b9319a82 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -69,6 +69,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Onandimm n, v1::nil => notint (and v1 (I n)) | Oor, v1::v2::nil => or v1 v2 | Oorimm n, v1::nil => or v1 (I n) + | Onor, v1::v2::nil => notint (or v1 v2) + | Onorimm n, v1::nil => notint (or v1 (I n)) | Oxor, v1::v2::nil => xor v1 v2 | Oxorimm n, v1::nil => xor v1 (I n) | Oshl, v1::v2::nil => shl v1 v2 -- cgit From 2227019e15866870f87488630f17cbb0797d1786 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 19:00:55 +0100 Subject: nxor --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmblock.v | 4 ++++ mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/Asmblockgen.v | 7 +++++++ mppa_k1c/NeedOp.v | 4 ++++ mppa_k1c/Op.v | 12 ++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 9 ++++++--- mppa_k1c/SelectOp.v | 10 ++++++++++ mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 2 ++ mppa_k1c/TargetPrinter.ml | 4 ++++ mppa_k1c/ValueAOp.v | 2 ++ 12 files changed, 59 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 3e4e4db7..2fd46689 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -142,6 +142,7 @@ Inductive instruction : Type := | 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 *) | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) @@ -172,6 +173,7 @@ Inductive instruction : Type := | 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 *) | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) @@ -267,6 +269,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2 | PArithRRR Asmblock.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmblock.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 | PArithRRR Asmblock.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 @@ -296,6 +299,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm | PArithRRI32 Asmblock.Pnoriw rd rs imm => Pnoriw rd rs imm | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmblock.Pnxoriw rd rs imm => Pnxoriw rd rs imm | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 66878a94..6e55b074 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -342,6 +342,7 @@ Inductive arith_name_rrr : Type := | Porw (**r or word *) | Pnorw (**r nor word *) | Pxorw (**r xor word *) + | Pnxorw (**r nxor word *) | Psraw (**r shift right arithmetic word *) | Psrlw (**r shift right logical word *) | Psllw (**r shift left logical word *) @@ -373,6 +374,7 @@ Inductive arith_name_rri32 : Type := | Poriw (**r or imm word *) | Pnoriw (**r nor imm word *) | Pxoriw (**r xor imm word *) + | Pnxoriw (**r nxor imm word *) | Psraiw (**r shift right arithmetic imm word *) | Psrliw (**r shift right logical imm word *) | Pslliw (**r shift left logical imm word *) @@ -1099,6 +1101,7 @@ Definition arith_eval_rrr n v1 v2 := | Porw => Val.or v1 v2 | Pnorw => Val.notint (Val.or v1 v2) | Pxorw => Val.xor v1 v2 + | Pnxorw => Val.notint (Val.xor v1 v2) | Psrlw => Val.shru v1 v2 | Psraw => Val.shr v1 v2 | Psllw => Val.shl v1 v2 @@ -1130,6 +1133,7 @@ Definition arith_eval_rri32 n v i := | Poriw => Val.or v (Vint i) | Pnoriw => Val.notint (Val.or v (Vint i)) | Pxoriw => Val.xor v (Vint i) + | Pnxoriw => Val.notint (Val.xor v (Vint i)) | Psraiw => Val.shr v (Vint i) | Psrliw => Val.shru v (Vint i) | Pslliw => Val.shl v (Vint i) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0694c22f..9266a09b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1304,6 +1304,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Porw => "Porw" | Pnorw => "Pnorw" | Pxorw => "Pxorw" + | Pnxorw => "Pnxorw" | Psraw => "Psraw" | Psrlw => "Psrlw" | Psllw => "Psllw" @@ -1333,6 +1334,7 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := | Poriw => "Poriw" | Pnoriw => "Pnoriw" | Pxoriw => "Pxoriw" + | Pnxoriw => "Pnxoriw" | Psraiw => "Psraiw" | Psrliw => "Psrliw" | Pslliw => "Pslliw" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 9b9e9a12..f32d14bb 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -90,6 +90,7 @@ Definition nandimm32 := opimm32 Pnandw Pnandiw. 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. @@ -460,6 +461,12 @@ Definition transl_op | Oxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm32 rd rs n ::i k) + | Onxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnxorw rd rs1 rs2 ::i k) + | Onxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nxorimm32 rd rs n ::i k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 ::i k) diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 3442e3c1..b8f120f5 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -55,6 +55,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onorimm n => op1 (orimm nv n) | Oxor => op2 (bitwise nv) | Oxorimm n => op1 (bitwise nv) + | Onxor => op2 (bitwise nv) + | Onxorimm n => op1 (bitwise nv) | Oshl | Oshr | Oshru => op2 (default nv) | Oshlimm n => op1 (shlimm nv n) | Oshrimm n => op1 (shrimm nv n) @@ -160,6 +162,8 @@ Proof. - apply notint_sound; apply orimm_sound; auto. - apply xor_sound; auto. - apply xor_sound; auto with na. +- apply notint_sound; apply xor_sound; auto. +- apply notint_sound; apply xor_sound; auto with na. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 275613bb..a67fa27f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -86,6 +86,8 @@ Inductive operation : Type := | 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)] *) | Oshl (**r [rd = r1 << r2] *) | Oshlimm (n: int) (**r [rd = r1 << n] *) | Oshr (**r [rd = r1 >> r2] (signed) *) @@ -260,6 +262,8 @@ Definition eval_operation | Onorimm n, v1 :: nil => Some (Val.notint (Val.or v1 (Vint n))) | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Onxor, v1 :: v2 :: nil => Some (Val.notint (Val.xor v1 v2)) + | Onxorimm n, v1 :: nil => Some (Val.notint (Val.xor v1 (Vint n))) | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) @@ -421,6 +425,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Onorimm _ => (Tint :: nil, Tint) | Oxor => (Tint :: Tint :: nil, Tint) | Oxorimm _ => (Tint :: nil, Tint) + | Onxor => (Tint :: Tint :: nil, Tint) + | Onxorimm _ => (Tint :: nil, Tint) | Oshl => (Tint :: Tint :: nil, Tint) | Oshlimm _ => (Tint :: nil, Tint) | Oshr => (Tint :: Tint :: nil, Tint) @@ -576,6 +582,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* xor, xorimm *) - destruct v0; destruct v1... - destruct v0... + (* nxor, nxorimm *) + - destruct v0; destruct v1... + - destruct v0... (* shl, shlimm *) - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... @@ -1046,6 +1055,9 @@ Proof. (* xor, xorimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* nxor, nxorimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* shl, shlimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c674bf3e..2d25c281 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -65,6 +65,7 @@ let arith_rrr_str = function | Porw -> "Porw" | Pnorw -> "Pnorw" | Pxorw -> "Pxorw" + | Pnxorw -> "Pnxorw" | Psraw -> "Psraw" | Psrlw -> "Psrlw" | Psllw -> "Psllw" @@ -92,6 +93,7 @@ let arith_rri32_str = function | Poriw -> "Poriw" | Pnoriw -> "Pnoriw" | Pxoriw -> "Pxoriw" + | Pnxoriw -> "Pnxoriw" | Psraiw -> "Psraiw" | Psrliw -> "Psrliw" | Pslliw -> "Pslliw" @@ -382,7 +384,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord - | Nandw | Norw + | Nandw | Norw | Nxorw | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -420,6 +422,7 @@ let ab_inst_to_real = function | "Proriw" -> Rorw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw + | "Pnxorw" | "Pnxoriw" -> Nxorw | "Pxorl" | "Pxoril" -> Xord | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop @@ -482,7 +485,7 @@ let rec_to_usage r = (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst in match real_inst with - | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw -> + | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw | Nxorw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) @@ -535,7 +538,7 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw - | Rorw | Nandw | Norw + | Rorw | Nandw | Norw | Nxorw | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index 028c2eb1..109d447b 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -728,6 +728,8 @@ Nondetfunction notint (e: expr) := | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) + | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) + | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) | _ => xorimm Int.mone e end. >> @@ -738,6 +740,8 @@ Inductive notint_cases: forall (e: expr), Type := | notint_case2: forall n e1, notint_cases (Eop (Oandimm n) (e1:::Enil)) | notint_case3: forall e1 e2, notint_cases (Eop Oor (e1:::e2:::Enil)) | notint_case4: forall n e1, notint_cases (Eop (Oorimm n) (e1:::Enil)) + | notint_case5: forall e1 e2, notint_cases (Eop Oxor (e1:::e2:::Enil)) + | notint_case6: forall n e1, notint_cases (Eop (Oxorimm n) (e1:::Enil)) | notint_default: forall (e: expr), notint_cases e. Definition notint_match (e: expr) := @@ -746,6 +750,8 @@ Definition notint_match (e: expr) := | Eop (Oandimm n) (e1:::Enil) => notint_case2 n e1 | Eop Oor (e1:::e2:::Enil) => notint_case3 e1 e2 | Eop (Oorimm n) (e1:::Enil) => notint_case4 n e1 + | Eop Oxor (e1:::e2:::Enil) => notint_case5 e1 e2 + | Eop (Oxorimm n) (e1:::Enil) => notint_case6 n e1 | e => notint_default e end. @@ -759,6 +765,10 @@ Definition notint (e: expr) := Eop Onor (e1:::e2:::Enil) | notint_case4 n e1 => (* Eop (Oorimm n) (e1:::Enil) *) Eop (Onorimm n) (e1:::Enil) + | notint_case5 e1 e2 => (* Eop Oxor (e1:::e2:::Enil) *) + Eop Onxor (e1:::e2:::Enil) + | notint_case6 n e1 => (* Eop (Oxorimm n) (e1:::Enil) *) + Eop (Onxorimm n) (e1:::Enil) | notint_default e => xorimm Int.mone e end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3f806dda..a45e3403 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -281,6 +281,8 @@ Nondetfunction notint (e: expr) := | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) + | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) + | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) | _ => xorimm Int.mone e end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 59ea598a..73b345d3 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -531,6 +531,8 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. - apply eval_xorimm; assumption. Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 07663074..49ea53b9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -378,6 +378,8 @@ module Target (*: TARGET*) = fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorw (rd, rs1, rs2) -> fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnxorw (rd, rs1, rs2) -> + fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> @@ -432,6 +434,8 @@ module Target (*: TARGET*) = fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pxoriw (rd, rs, imm) -> fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnxoriw (rd, rs, imm) -> + fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psrliw (rd, rs, imm) -> diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index b9319a82..15378811 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -73,6 +73,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Onorimm n, v1::nil => notint (or v1 (I n)) | Oxor, v1::v2::nil => xor v1 v2 | Oxorimm n, v1::nil => xor v1 (I n) + | Onxor, v1::v2::nil => notint (xor v1 v2) + | Onxorimm n, v1::nil => notint (xor v1 (I n)) | Oshl, v1::v2::nil => shl v1 v2 | Oshlimm n, v1::nil => shl v1 (I n) | Oshr, v1::v2::nil => shr v1 v2 -- cgit From 7ab24b18b1c9a08b0d092c2c8144ee7b3a029c1d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 16 Mar 2019 19:47:03 +0100 Subject: long nand, nor, nxor --- mppa_k1c/Asm.v | 12 ++++++++++++ mppa_k1c/Asmblock.v | 12 ++++++++++++ mppa_k1c/Asmblockdeps.v | 6 ++++++ mppa_k1c/Asmblockgen.v | 21 +++++++++++++++++++++ mppa_k1c/NeedOp.v | 6 ++++++ mppa_k1c/Op.v | 36 ++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 15 ++++++++++++--- mppa_k1c/SelectLong.vp | 13 +++++++++++-- mppa_k1c/SelectLongproof.v | 12 ++++++++++-- mppa_k1c/TargetPrinter.ml | 12 ++++++++++++ mppa_k1c/ValueAOp.v | 6 ++++++ 11 files changed, 144 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 2fd46689..354840d4 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -150,8 +150,11 @@ Inductive instruction : Type := | 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 *) | 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 *) @@ -186,8 +189,11 @@ Inductive instruction : Type := | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) | Paddil (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 *) . (** Correspondance between Asmblock and Asm *) @@ -277,8 +283,11 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 | PArithRRR Asmblock.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 | PArithRRR Asmblock.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmblock.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 | PArithRRR Asmblock.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmblock.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 | PArithRRR Asmblock.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmblock.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 | PArithRRR Asmblock.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 | PArithRRR Asmblock.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 @@ -312,8 +321,11 @@ Definition basic_to_instruction (b: basic) := | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm | PArithRRI64 Asmblock.Paddil rd rs imm => Paddil rd rs imm | PArithRRI64 Asmblock.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmblock.Pnandil rd rs imm => Pnandil rd rs imm | PArithRRI64 Asmblock.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmblock.Pnoril rd rs imm => Pnoril rd rs imm | PArithRRI64 Asmblock.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmblock.Pnxoril rd rs imm => Pnxoril rd rs imm (** Load *) | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 6e55b074..5279bd29 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -350,8 +350,11 @@ Inductive arith_name_rrr : Type := | Paddl (**r add long *) | Psubl (**r sub long *) | Pandl (**r and long *) + | Pnandl (**r nand long *) | Porl (**r or long *) + | Pnorl (**r nor long *) | Pxorl (**r xor long *) + | Pnxorl (**r nxor long *) | Pmull (**r mul long (low part) *) | Pslll (**r shift left logical long *) | Psrll (**r shift right logical long *) @@ -388,8 +391,11 @@ Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) | Pandil (**r and immediate long *) + | Pnandil (**r nand immediate long *) | Poril (**r or immediate long *) + | Pnoril (**r nor immediate long *) | Pxoril (**r xor immediate long *) + | Pnxoril (**r nxor immediate long *) . Inductive ar_instruction : Type := @@ -1109,8 +1115,11 @@ Definition arith_eval_rrr n v1 v2 := | Paddl => Val.addl v1 v2 | Psubl => Val.subl v1 v2 | Pandl => Val.andl v1 v2 + | Pnandl => Val.notl (Val.andl v1 v2) | Porl => Val.orl v1 v2 + | Pnorl => Val.notl (Val.orl v1 v2) | Pxorl => Val.xorl v1 v2 + | Pnxorl => Val.notl (Val.xorl v1 v2) | Pmull => Val.mull v1 v2 | Pslll => Val.shll v1 v2 | Psrll => Val.shrlu v1 v2 @@ -1148,8 +1157,11 @@ Definition arith_eval_rri64 n v i := | Pcompil c => compare_long c v (Vlong i) | Paddil => Val.addl v (Vlong i) | Pandil => Val.andl v (Vlong i) + | Pnandil => Val.notl (Val.andl v (Vlong i)) | Poril => Val.orl v (Vlong i) + | Pnoril => Val.notl (Val.orl v (Vlong i)) | Pxoril => Val.xorl v (Vlong i) + | Pnxoril => Val.notl (Val.xorl v (Vlong i)) end. Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9266a09b..c5b5bd56 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1311,8 +1311,11 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Paddl => "Paddl" | Psubl => "Psubl" | Pandl => "Pandl" + | Pnandl => "Pnandl" | Porl => "Porl" + | Pnorl => "Pnorl" | Pxorl => "Pxorl" + | Pnxorl => "Pnxorl" | Pmull => "Pmull" | Pslll => "Pslll" | Psrll => "Psrll" @@ -1349,8 +1352,11 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := Pcompil _ => "Pcompil" | Paddil => "Paddil" | Pandil => "Pandil" + | Pnandil => "Pnandil" | Poril => "Poril" + | Pnoril => "Pnoril" | Pxoril => "Pxoril" + | Pnxoril => "Pnxoril" end. Definition string_of_arith (op: arith_op): pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f32d14bb..9d682bed 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -112,6 +112,9 @@ Definition addimm64 := opimm64 Paddl Paddil. Definition orimm64 := opimm64 Porl Poril. Definition andimm64 := opimm64 Pandl Pandil. Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition norimm64 := opimm64 Pnorl Pnoril. +Definition nandimm64 := opimm64 Pnandl Pnandil. +Definition nxorimm64 := opimm64 Pnxorl Pnxoril. (* Definition sltimm64 := opimm64 Psltl Psltil. @@ -535,18 +538,36 @@ Definition transl_op | Oandlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (andimm64 rd rs n ::i k) + | Onandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnandl rd rs1 rs2 ::i k) + | Onandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nandimm64 rd rs n ::i k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 ::i k) | Oorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (orimm64 rd rs n ::i k) + | Onorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnorl rd rs1 rs2 ::i k) + | Onorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (norimm64 rd rs n ::i k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 ::i k) | Oxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (xorimm64 rd rs n ::i k) + | Onxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnxorl rd rs1 rs2 ::i k) + | Onxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nxorimm64 rd rs n ::i k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 ::i k) diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index b8f120f5..f7b13cad 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -75,10 +75,16 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) | Oandl => op2 (default nv) | Oandlimm n => op1 (default nv) + | Onandl => op2 (default nv) + | Onandlimm n => op1 (default nv) | Oorl => op2 (default nv) | Oorlimm n => op1 (default nv) + | Onorl => op2 (default nv) + | Onorlimm n => op1 (default nv) | Oxorl => op2 (default nv) | Oxorlimm n => op1 (default nv) + | Onxorl => op2 (default nv) + | Onxorlimm n => op1 (default nv) | Oshll | Oshrl | Oshrlu => op2 (default nv) | Oshllimm n => op1 (default nv) | Oshrlimm n => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index a67fa27f..bf42b65f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -115,10 +115,16 @@ Inductive operation : Type := | Omodlu (**r [rd = r1 % r2] (unsigned) *) | Oandl (**r [rd = r1 & r2] *) | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Onandl (**r [rd = ~(r1 & r2)] *) + | Onandlimm (n: int64) (**r [rd = ~(r1 & n)] *) | Oorl (**r [rd = r1 | r2] *) | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Onorl (**r [rd = ~(r1 | r2)] *) + | Onorlimm (n: int64) (**r [rd = ~(r1 | n)] *) | Oxorl (**r [rd = r1 ^ r2] *) | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Onxorl (**r [rd = ~(r1 ^ r2)] *) + | Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *) | Oshll (**r [rd = r1 << r2] *) | Oshllimm (n: int) (**r [rd = r1 << n] *) | Oshrl (**r [rd = r1 >> r2] (signed) *) @@ -290,10 +296,16 @@ Definition eval_operation | Omodlu, v1::v2::nil => Val.modlu v1 v2 | Oandl, v1::v2::nil => Some(Val.andl v1 v2) | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) + | Onandl, v1::v2::nil => Some(Val.notl (Val.andl v1 v2)) + | Onandlimm n, v1::nil => Some(Val.notl (Val.andl v1 (Vlong n))) | Oorl, v1::v2::nil => Some(Val.orl v1 v2) | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) + | Onorl, v1::v2::nil => Some(Val.notl (Val.orl v1 v2)) + | Onorlimm n, v1::nil => Some(Val.notl (Val.orl v1 (Vlong n))) | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | Onxorl, v1::v2::nil => Some(Val.notl (Val.xorl v1 v2)) + | Onxorlimm n, v1::nil => Some(Val.notl (Val.xorl v1 (Vlong n))) | Oshll, v1::v2::nil => Some (Val.shll v1 v2) | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) @@ -453,10 +465,16 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omodlu => (Tlong :: Tlong :: nil, Tlong) | Oandl => (Tlong :: Tlong :: nil, Tlong) | Oandlimm _ => (Tlong :: nil, Tlong) + | Onandl => (Tlong :: Tlong :: nil, Tlong) + | Onandlimm _ => (Tlong :: nil, Tlong) | Oorl => (Tlong :: Tlong :: nil, Tlong) | Oorlimm _ => (Tlong :: nil, Tlong) + | Onorl => (Tlong :: Tlong :: nil, Tlong) + | Onorlimm _ => (Tlong :: nil, Tlong) | Oxorl => (Tlong :: Tlong :: nil, Tlong) | Oxorlimm _ => (Tlong :: nil, Tlong) + | Onxorl => (Tlong :: Tlong :: nil, Tlong) + | Onxorlimm _ => (Tlong :: nil, Tlong) | Oshll => (Tlong :: Tint :: nil, Tlong) | Oshllimm _ => (Tlong :: nil, Tlong) | Oshrl => (Tlong :: Tint :: nil, Tlong) @@ -630,12 +648,21 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* andl, andlimm *) - destruct v0; destruct v1... - destruct v0... + (* nandl, nandlimm *) + - destruct v0; destruct v1... + - destruct v0... (* orl, orlimm *) - destruct v0; destruct v1... - destruct v0... + (* norl, norlimm *) + - destruct v0; destruct v1... + - destruct v0... (* xorl, xorlimm *) - destruct v0; destruct v1... - destruct v0... + (* nxorl, nxorlimm *) + - destruct v0; destruct v1... + - destruct v0... (* shll, shllimm *) - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... @@ -1106,12 +1133,21 @@ Proof. (* andl, andlimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* nandl, nandlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* orl, orlimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* norl, norlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* xorl, xorlimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* nxorl, nxorlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* shll, shllimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2d25c281..3c242441 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -72,8 +72,11 @@ let arith_rrr_str = function | Paddl -> "Paddl" | Psubl -> "Psubl" | Pandl -> "Pandl" + | Pnandl -> "Pnandl" | Porl -> "Porl" + | Pnorl -> "Pnorl" | Pxorl -> "Pxorl" + | Pnxorl -> "Pnxorl" | Pmull -> "Pmull" | Pslll -> "Pslll" | Psrll -> "Psrll" @@ -106,8 +109,11 @@ let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" | Pandil -> "Pandil" + | Pnandil -> "Pnandil" | Poril -> "Poril" + | Pnoril -> "Pnoril" | Pxoril -> "Pxoril" + | Pnxoril -> "Pnxoril" let arith_ri32_str = "Pmake" @@ -384,7 +390,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord - | Nandw | Norw | Nxorw + | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -403,6 +409,7 @@ let ab_inst_to_real = function | "Pandw" | "Pandiw" -> Andw | "Pnandw" | "Pnandiw" -> Nandw | "Pandl" | "Pandil" -> Andd + | "Pnandl" | "Pnandil" -> Nandd | "Pcompw" | "Pcompiw" -> Compw | "Pcompl" | "Pcompil" -> Compd | "Pfcompw" -> Fcompw @@ -412,6 +419,7 @@ let ab_inst_to_real = function | "Porw" | "Poriw" -> Orw | "Pnorw" | "Pnoriw" -> Norw | "Porl" | "Poril" -> Ord + | "Pnorl" | "Pnoril" -> Nord | "Psubw" | "Pnegw" -> Sbfw | "Psubl" | "Pnegl" -> Sbfd | "Psraw" | "Psraiw" -> Sraw @@ -424,6 +432,7 @@ let ab_inst_to_real = function | "Pxorw" | "Pxoriw" -> Xorw | "Pnxorw" | "Pnxoriw" -> Nxorw | "Pxorl" | "Pxoril" -> Xord + | "Pnxorl" | "Pnxoril" -> Nxord | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd @@ -489,7 +498,7 @@ let rec_to_usage r = (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) - | Addd | Andd | Ord | Sbfd | Xord -> + | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord | Nxord -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) @@ -538,7 +547,7 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw - | Rorw | Nandw | Norw | Nxorw + | Rorw | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 5e94fbb5..cc266abd 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -287,8 +287,17 @@ Nondetfunction xorl (e1: expr) (e2: expr) := (** ** Integer logical negation *) -Definition notl (e: expr) := - if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. +Nondetfunction notl (e: expr) := + match e with + | Eop Oandl (e1:::e2:::Enil) => Eop Onandl (e1:::e2:::Enil) + | Eop (Oandlimm n) (e1:::Enil) => Eop (Onandlimm n) (e1:::Enil) + | Eop Oorl (e1:::e2:::Enil) => Eop Onorl (e1:::e2:::Enil) + | Eop (Oorlimm n) (e1:::Enil) => Eop (Onorlimm n) (e1:::Enil) + | Eop Oxorl (e1:::e2:::Enil) => Eop Onxorl (e1:::e2:::Enil) + | Eop (Oxorlimm n) (e1:::Enil) => Eop (Onxorlimm n) (e1:::Enil) + | _ => xorlimm Int64.mone e + end. +(* old: if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. *) (** ** Integer division and modulus *) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 44846a6f..a8a6bc9c 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -441,8 +441,16 @@ Qed. Theorem eval_notl: unary_constructor_sound notl Val.notl. Proof. - unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl. - red; intros. rewrite Val.notl_xorl. apply eval_xorlimm; auto. + assert (forall v, Val.lessdef (Val.notl (Val.notl v)) v). + destruct v; simpl; auto. rewrite Int64.not_involutive; auto. + unfold notl; red; intros until x; case (notl_match a); intros; InvEval. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - apply eval_xorlimm; assumption. Qed. Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 49ea53b9..d30d62a2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -393,10 +393,16 @@ module Target (*: TARGET*) = fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnandl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Porl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnorl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnxorl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmull (rd, rs1, rs2) -> fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pslll (rd, rs1, rs2) -> @@ -459,10 +465,16 @@ module Target (*: TARGET*) = fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pxoril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 15378811..33f4d8a9 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -101,10 +101,16 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omodlu, v1::v2::nil => modlu v1 v2 | Oandl, v1::v2::nil => andl v1 v2 | Oandlimm n, v1::nil => andl v1 (L n) + | Onandl, v1::v2::nil => notl (andl v1 v2) + | Onandlimm n, v1::nil => notl (andl v1 (L n)) | Oorl, v1::v2::nil => orl v1 v2 | Oorlimm n, v1::nil => orl v1 (L n) + | Onorl, v1::v2::nil => notl (orl v1 v2) + | Onorlimm n, v1::nil => notl (orl v1 (L n)) | Oxorl, v1::v2::nil => xorl v1 v2 | Oxorlimm n, v1::nil => xorl v1 (L n) + | Onxorl, v1::v2::nil => notl (xorl v1 v2) + | Onxorlimm n, v1::nil => notl (xorl v1 (L n)) | Oshll, v1::v2::nil => shll v1 v2 | Oshllimm n, v1::nil => shll v1 (I n) | Oshrl, v1::v2::nil => shrl v1 v2 -- cgit From 2ef85f12a76c1d730324001c8cc62b4d8828a109 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 10:19:55 +0100 Subject: begin andn orn --- mppa_k1c/NeedOp.v | 15 +++++++++++++ mppa_k1c/Op.v | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/ValueAOp.v | 10 +++++++++ 3 files changed, 87 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index f7b13cad..12d7a4f7 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -57,6 +57,11 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oxorimm n => op1 (bitwise nv) | Onxor => op2 (bitwise nv) | Onxorimm n => op1 (bitwise nv) + | Onot => op1 (bitwise nv) + | Oandn => op2 (bitwise nv) + | Oandnimm n => op1 (andimm nv n) + | Oorn => op2 (bitwise nv) + | Oornimm n => op1 (orimm nv n) | Oshl | Oshr | Oshru => op2 (default nv) | Oshlimm n => op1 (shlimm nv n) | Oshrimm n => op1 (shrimm nv n) @@ -85,6 +90,11 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oxorlimm n => op1 (default nv) | Onxorl => op2 (default nv) | Onxorlimm n => op1 (default nv) + | Onotl => op1 (default nv) + | Oandnl => op2 (default nv) + | Oandnlimm n => op1 (default nv) + | Oornl => op2 (default nv) + | Oornlimm n => op1 (default nv) | Oshll | Oshrl | Oshrlu => op2 (default nv) | Oshllimm n => op1 (default nv) | Oshrlimm n => op1 (default nv) @@ -170,6 +180,11 @@ Proof. - apply xor_sound; auto with na. - apply notint_sound; apply xor_sound; auto. - apply notint_sound; apply xor_sound; auto with na. +- apply notint_sound; auto. +- apply and_sound; try apply notint_sound; auto with na. +- apply andimm_sound; try apply notint_sound; auto with na. +- apply or_sound; try apply notint_sound; auto with na. +- apply orimm_sound; try apply notint_sound; auto with na. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index bf42b65f..04ea8945 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -88,6 +88,11 @@ Inductive operation : Type := | 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] *) + | 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) *) @@ -125,6 +130,11 @@ Inductive operation : Type := | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) | 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] *) + | Oornl (**r [rd = (~r1) | r2] *) + | Oornlimm (n: int64) (**r [rd = (~r1) | n] *) | Oshll (**r [rd = r1 << r2] *) | Oshllimm (n: int) (**r [rd = r1 << n] *) | Oshrl (**r [rd = r1 >> r2] (signed) *) @@ -270,6 +280,11 @@ Definition eval_operation | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) | Onxor, v1 :: v2 :: nil => Some (Val.notint (Val.xor v1 v2)) | Onxorimm n, v1 :: nil => Some (Val.notint (Val.xor v1 (Vint n))) + | Onot, v1 :: nil => Some (Val.notint v1) + | Oandn, v1 :: v2 :: nil => Some (Val.and (Val.notint v1) v2) + | Oandnimm n, v1 :: nil => Some (Val.and (Val.notint v1) (Vint n)) + | Oorn, v1 :: v2 :: nil => Some (Val.or (Val.notint v1) v2) + | Oornimm n, v1 :: nil => Some (Val.or (Val.notint v1) (Vint n)) | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) @@ -306,6 +321,11 @@ Definition eval_operation | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) | Onxorl, v1::v2::nil => Some(Val.notl (Val.xorl v1 v2)) | Onxorlimm n, v1::nil => Some(Val.notl (Val.xorl v1 (Vlong n))) + | Onotl, v1 :: nil => Some (Val.notl v1) + | Oandnl, v1 :: v2 :: nil => Some (Val.andl (Val.notl v1) v2) + | Oandnlimm n, v1 :: nil => Some (Val.andl (Val.notl v1) (Vlong n)) + | Oornl, v1 :: v2 :: nil => Some (Val.orl (Val.notl v1) v2) + | Oornlimm n, v1 :: nil => Some (Val.orl (Val.notl v1) (Vlong n)) | Oshll, v1::v2::nil => Some (Val.shll v1 v2) | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) @@ -439,6 +459,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oxorimm _ => (Tint :: nil, Tint) | Onxor => (Tint :: Tint :: nil, Tint) | Onxorimm _ => (Tint :: nil, Tint) + | Onot => (Tint :: nil, Tint) + | Oandn => (Tint :: Tint :: nil, Tint) + | Oandnimm _ => (Tint :: nil, Tint) + | Oorn => (Tint :: Tint :: nil, Tint) + | Oornimm _ => (Tint :: nil, Tint) | Oshl => (Tint :: Tint :: nil, Tint) | Oshlimm _ => (Tint :: nil, Tint) | Oshr => (Tint :: Tint :: nil, Tint) @@ -475,6 +500,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oxorlimm _ => (Tlong :: nil, Tlong) | Onxorl => (Tlong :: Tlong :: nil, Tlong) | Onxorlimm _ => (Tlong :: nil, Tlong) + | Onotl => (Tlong :: nil, Tlong) + | Oandnl => (Tlong :: Tlong :: nil, Tlong) + | Oandnlimm _ => (Tlong :: nil, Tlong) + | Oornl => (Tlong :: Tlong :: nil, Tlong) + | Oornlimm _ => (Tlong :: nil, Tlong) | Oshll => (Tlong :: Tint :: nil, Tlong) | Oshllimm _ => (Tlong :: nil, Tlong) | Oshrl => (Tlong :: Tint :: nil, Tlong) @@ -603,6 +633,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* nxor, nxorimm *) - destruct v0; destruct v1... - destruct v0... + (* not *) + - destruct v0... + (* andn, andnimm *) + - destruct v0; destruct v1... + - destruct v0... + (* orn, ornimm *) + - destruct v0; destruct v1... + - destruct v0... (* shl, shlimm *) - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... @@ -663,6 +701,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* nxorl, nxorlimm *) - destruct v0; destruct v1... - destruct v0... + (* notl *) + - destruct v0... + (* andnl, andnlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* ornl, ornlimm *) + - destruct v0; destruct v1... + - destruct v0... (* shll, shllimm *) - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... @@ -1085,6 +1131,14 @@ Proof. (* nxor, nxorimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* not *) + - inv H4; simpl; auto. + (* andn, andnimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* orn, ornimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* shl, shlimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. @@ -1148,6 +1202,14 @@ Proof. (* nxorl, nxorlimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. + (* notl *) + - inv H4; simpl; auto. + (* andnl, andnlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* ornl, ornlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. (* shll, shllimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 33f4d8a9..57676b35 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -75,6 +75,11 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oxorimm n, v1::nil => xor v1 (I n) | Onxor, v1::v2::nil => notint (xor v1 v2) | Onxorimm n, v1::nil => notint (xor v1 (I n)) + | Onot, v1::nil => notint v1 + | Oandn, v1::v2::nil => and (notint v1) v2 + | Oandnimm n, v1::nil => and (notint v1) (I n) + | Oorn, v1::v2::nil => or (notint v1) v2 + | Oornimm n, v1::nil => or (notint v1) (I n) | Oshl, v1::v2::nil => shl v1 v2 | Oshlimm n, v1::nil => shl v1 (I n) | Oshr, v1::v2::nil => shr v1 v2 @@ -111,6 +116,11 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oxorlimm n, v1::nil => xorl v1 (L n) | Onxorl, v1::v2::nil => notl (xorl v1 v2) | Onxorlimm n, v1::nil => notl (xorl v1 (L n)) + | Onotl, v1::nil => notl v1 + | Oandnl, v1::v2::nil => andl (notl v1) v2 + | Oandnlimm n, v1::nil => andl (notl v1) (L n) + | Oornl, v1::v2::nil => orl (notl v1) v2 + | Oornlimm n, v1::nil => orl (notl v1) (L n) | Oshll, v1::v2::nil => shll v1 v2 | Oshllimm n, v1::nil => shll v1 (I n) | Oshrl, v1::v2::nil => shrl v1 v2 -- cgit From 6ecca2e4797af8effde673b8f188d562fdfc89a6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 10:33:39 +0100 Subject: some more about andn/orn --- mppa_k1c/Asm.v | 8 ++++++++ mppa_k1c/TargetPrinter.ml | 16 ++++++++++++++++ 2 files changed, 24 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 354840d4..e07b1190 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -143,6 +143,8 @@ Inductive instruction : Type := | 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 *) | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) @@ -155,6 +157,8 @@ Inductive instruction : Type := | 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 *) @@ -177,6 +181,8 @@ Inductive instruction : Type := | 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 *) | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) @@ -194,6 +200,8 @@ Inductive instruction : Type := | 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 *) . (** Correspondance between Asmblock and Asm *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d30d62a2..c3de5206 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -380,6 +380,10 @@ module Target (*: TARGET*) = fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pnxorw (rd, rs1, rs2) -> fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pandnw (rd, rs1, rs2) -> + fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pornw (rd, rs1, rs2) -> + fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> @@ -403,6 +407,10 @@ module Target (*: TARGET*) = fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pnxorl (rd, rs1, rs2) -> assert Archi.ptr64; 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 + | Pornl (rd, rs1, rs2) -> + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmull (rd, rs1, rs2) -> fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pslll (rd, rs1, rs2) -> @@ -442,6 +450,10 @@ module Target (*: TARGET*) = fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pnxoriw (rd, rs, imm) -> fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pandniw (rd, rs, imm) -> + fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Porniw (rd, rs, imm) -> + fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psrliw (rd, rs, imm) -> @@ -475,6 +487,10 @@ module Target (*: TARGET*) = fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pandnil (rd, rs, imm) -> + fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pornil (rd, rs, imm) -> + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint imm let get_section_names name = let (text, lit) = -- cgit From 4bd693ddb0f1489c301927fd0eb521cf3505ac2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 11:01:43 +0100 Subject: orn / andn in asm --- mppa_k1c/Asm.v | 8 ++++++++ mppa_k1c/Asmblock.v | 16 ++++++++++++++++ mppa_k1c/Asmblockdeps.v | 8 ++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 22 ++++++++++++++++++---- 4 files changed, 50 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e07b1190..8486e25d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -284,6 +284,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 | PArithRRR Asmblock.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmblock.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmblock.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 | PArithRRR Asmblock.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 @@ -296,6 +298,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmblock.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 | PArithRRR Asmblock.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 | PArithRRR Asmblock.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmblock.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmblock.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 | PArithRRR Asmblock.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 | PArithRRR Asmblock.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 @@ -317,6 +321,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 Asmblock.Pnoriw rd rs imm => Pnoriw rd rs imm | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm | PArithRRI32 Asmblock.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmblock.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmblock.Porniw rd rs imm => Porniw rd rs imm | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm @@ -334,6 +340,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRI64 Asmblock.Pnoril rd rs imm => Pnoril rd rs imm | PArithRRI64 Asmblock.Pxoril rd rs imm => Pxoril rd rs imm | PArithRRI64 Asmblock.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmblock.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmblock.Pornil rd rs imm => Pornil rd rs imm (** Load *) | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 5279bd29..cdbe4eb3 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -343,6 +343,8 @@ Inductive arith_name_rrr : Type := | Pnorw (**r nor word *) | Pxorw (**r xor word *) | Pnxorw (**r nxor word *) + | Pandnw (**r andn word *) + | Pornw (**r orn word *) | Psraw (**r shift right arithmetic word *) | Psrlw (**r shift right logical word *) | Psllw (**r shift left logical word *) @@ -355,6 +357,8 @@ Inductive arith_name_rrr : Type := | Pnorl (**r nor long *) | Pxorl (**r xor long *) | Pnxorl (**r nxor long *) + | Pandnl (**r andn long *) + | Pornl (**r orn long *) | Pmull (**r mul long (low part) *) | Pslll (**r shift left logical long *) | Psrll (**r shift right logical long *) @@ -378,6 +382,8 @@ Inductive arith_name_rri32 : Type := | Pnoriw (**r nor imm word *) | Pxoriw (**r xor imm word *) | Pnxoriw (**r nxor imm word *) + | Pandniw (**r andn word *) + | Porniw (**r orn word *) | Psraiw (**r shift right arithmetic imm word *) | Psrliw (**r shift right logical imm word *) | Pslliw (**r shift left logical imm word *) @@ -396,6 +402,8 @@ Inductive arith_name_rri64 : Type := | Pnoril (**r nor immediate long *) | Pxoril (**r xor immediate long *) | Pnxoril (**r nxor immediate long *) + | Pandnil (**r andn immediate long *) + | Pornil (**r orn immediate long *) . Inductive ar_instruction : Type := @@ -1108,6 +1116,8 @@ Definition arith_eval_rrr n v1 v2 := | Pnorw => Val.notint (Val.or v1 v2) | Pxorw => Val.xor v1 v2 | Pnxorw => Val.notint (Val.xor v1 v2) + | Pandnw => Val.and (Val.notint v1) v2 + | Pornw => Val.or (Val.notint v1) v2 | Psrlw => Val.shru v1 v2 | Psraw => Val.shr v1 v2 | Psllw => Val.shl v1 v2 @@ -1120,6 +1130,8 @@ Definition arith_eval_rrr n v1 v2 := | Pnorl => Val.notl (Val.orl v1 v2) | Pxorl => Val.xorl v1 v2 | Pnxorl => Val.notl (Val.xorl v1 v2) + | Pandnl => Val.andl (Val.notl v1) v2 + | Pornl => Val.orl (Val.notl v1) v2 | Pmull => Val.mull v1 v2 | Pslll => Val.shll v1 v2 | Psrll => Val.shrlu v1 v2 @@ -1143,6 +1155,8 @@ Definition arith_eval_rri32 n v i := | Pnoriw => Val.notint (Val.or v (Vint i)) | Pxoriw => Val.xor v (Vint i) | Pnxoriw => Val.notint (Val.xor v (Vint i)) + | Pandniw => Val.and (Val.notint v) (Vint i) + | Porniw => Val.or (Val.notint v) (Vint i) | Psraiw => Val.shr v (Vint i) | Psrliw => Val.shru v (Vint i) | Pslliw => Val.shl v (Vint i) @@ -1162,6 +1176,8 @@ Definition arith_eval_rri64 n v i := | Pnoril => Val.notl (Val.orl v (Vlong i)) | Pxoril => Val.xorl v (Vlong 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) end. Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c5b5bd56..d69903b4 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1305,6 +1305,8 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pnorw => "Pnorw" | Pxorw => "Pxorw" | Pnxorw => "Pnxorw" + | Pandnw => "Pandnw" + | Pornw => "Pornw" | Psraw => "Psraw" | Psrlw => "Psrlw" | Psllw => "Psllw" @@ -1316,6 +1318,8 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pnorl => "Pnorl" | Pxorl => "Pxorl" | Pnxorl => "Pnxorl" + | Pandnl => "Pandnl" + | Pornl => "Pornl" | Pmull => "Pmull" | Pslll => "Pslll" | Psrll => "Psrll" @@ -1338,6 +1342,8 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := | Pnoriw => "Pnoriw" | Pxoriw => "Pxoriw" | Pnxoriw => "Pnxoriw" + | Pandniw => "Pandniw" + | Porniw => "Porniw" | Psraiw => "Psraiw" | Psrliw => "Psrliw" | Pslliw => "Pslliw" @@ -1357,6 +1363,8 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := | Pnoril => "Pnoril" | Pxoril => "Pxoril" | Pnxoril => "Pnxoril" + | Pandnil => "Pandnil" + | Pornil => "Pornil" end. Definition string_of_arith (op: arith_op): pstring := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3c242441..ce2fb2ae 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -66,6 +66,8 @@ let arith_rrr_str = function | Pnorw -> "Pnorw" | Pxorw -> "Pxorw" | Pnxorw -> "Pnxorw" + | Pandnw -> "Pandnw" + | Pornw -> "Pornw" | Psraw -> "Psraw" | Psrlw -> "Psrlw" | Psllw -> "Psllw" @@ -77,6 +79,8 @@ let arith_rrr_str = function | Pnorl -> "Pnorl" | Pxorl -> "Pxorl" | Pnxorl -> "Pnxorl" + | Pandnl -> "Pandnl" + | Pornl -> "Pornl" | Pmull -> "Pmull" | Pslll -> "Pslll" | Psrll -> "Psrll" @@ -97,6 +101,8 @@ let arith_rri32_str = function | Pnoriw -> "Pnoriw" | Pxoriw -> "Pxoriw" | Pnxoriw -> "Pnxoriw" + | Pandniw -> "Pandniw" + | Porniw -> "Porniw" | Psraiw -> "Psraiw" | Psrliw -> "Psrliw" | Pslliw -> "Pslliw" @@ -114,6 +120,8 @@ let arith_rri64_str = function | Pnoril -> "Pnoril" | Pxoril -> "Pxoril" | Pnxoril -> "Pnxoril" + | Pandnil -> "Pandnil" + | Pornil -> "Pornil" let arith_ri32_str = "Pmake" @@ -390,7 +398,7 @@ type real_instruction = (* ALU *) | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord - | Nandw | Norw | Nxorw | Nandd | Nord | Nxord + | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -431,8 +439,12 @@ let ab_inst_to_real = function | "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 | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd @@ -494,11 +506,11 @@ let rec_to_usage r = (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst in match real_inst with - | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw | Nxorw -> + | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) - | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord | Nxord -> + | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord | 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) @@ -547,7 +559,9 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw - | Rorw | Nandw | Norw | Nxorw | Nandd | Nord | Nxord + (* TODO check rorw *) + | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw + | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make | Sxwd | Zxwd | Fcompw | Fcompd -> 1 -- cgit From cfc949a5fce43f2d4e094b52ea42d619f64692c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 11:22:49 +0100 Subject: andn / orn suite --- mppa_k1c/Asmblockgen.v | 29 ++++++++++++++++++++++++++++- mppa_k1c/SelectLong.vp | 2 +- mppa_k1c/SelectLongproof.v | 2 +- mppa_k1c/SelectOp.v | 4 ++-- mppa_k1c/SelectOp.vp | 2 +- mppa_k1c/SelectOpproof.v | 2 +- 6 files changed, 34 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 9d682bed..c3ac217b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -469,7 +469,22 @@ Definition transl_op OK (Pnxorw rd rs1 rs2 ::i k) | Onxorimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (nxorimm32 rd rs n ::i k) + OK (nxorimm32 rd rs n ::i k) + | Onot, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs Int.mone ::i k) + | Oandn, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandnw rd rs1 rs2 ::i k) + | Oandnimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pandniw rd rs n ::i k) + | Oorn, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pornw rd rs1 rs2 ::i k) + | Oornimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Porniw rd rs n ::i k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 ::i k) @@ -568,6 +583,18 @@ Definition transl_op | Onxorlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (nxorimm64 rd rs n ::i k) + | Oandnl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandnl rd rs1 rs2 ::i k) + | Oandnlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pandnil rd rs n ::i k) + | Oornl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pornl rd rs1 rs2 ::i k) + | Oornlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pornil rd rs n ::i k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 ::i k) diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index cc266abd..dbd14b99 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -295,7 +295,7 @@ Nondetfunction notl (e: expr) := | Eop (Oorlimm n) (e1:::Enil) => Eop (Onorlimm n) (e1:::Enil) | Eop Oxorl (e1:::e2:::Enil) => Eop Onxorl (e1:::e2:::Enil) | Eop (Oxorlimm n) (e1:::Enil) => Eop (Onxorlimm n) (e1:::Enil) - | _ => xorlimm Int64.mone e + | _ => Eop Onotl (e:::Enil) end. (* old: if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. *) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index a8a6bc9c..27052edc 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -450,7 +450,7 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - - apply eval_xorlimm; assumption. + - TrivialExists. Qed. Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index 109d447b..78ab6261 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -730,7 +730,7 @@ Nondetfunction notint (e: expr) := | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) - | _ => xorimm Int.mone e + | _ => Eop Onot (e:::Enil) end. >> *) @@ -770,7 +770,7 @@ Definition notint (e: expr) := | notint_case6 n e1 => (* Eop (Oxorimm n) (e1:::Enil) *) Eop (Onxorimm n) (e1:::Enil) | notint_default e => - xorimm Int.mone e + Eop Onot (e:::Enil) end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index a45e3403..2878da1a 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -283,7 +283,7 @@ Nondetfunction notint (e: expr) := | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) - | _ => xorimm Int.mone e + | _ => Eop Onot (e:::Enil) end. (** ** Integer division and modulus *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 73b345d3..26df4fc7 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -533,7 +533,7 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - - apply eval_xorimm; assumption. + - TrivialExists. Qed. Theorem eval_divs_base: -- cgit From 19e9d0ca5d4ba59db9c1bc40842ac08b5ca4ac41 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 11:57:17 +0100 Subject: andn/orn start being generated --- mppa_k1c/SelectOp.v | 10 ++++++++++ mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 18 ++++++++++-------- 3 files changed, 22 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index 78ab6261..ada4ec2c 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -527,6 +527,7 @@ Nondetfunction and (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) | _, _ => Eop Oand (e1:::e2:::Enil) end. >> @@ -535,12 +536,14 @@ Nondetfunction and (e1: expr) (e2: expr) := Inductive and_cases: forall (e1: expr) (e2: expr), Type := | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) + | and_case3: forall t1 t2, and_cases ((Eop Onot (t1:::Enil))) (t2) | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. Definition and_match (e1: expr) (e2: expr) := match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 + | (Eop Onot (t1:::Enil)), t2 => and_case3 t1 t2 | e1, e2 => and_default e1 e2 end. @@ -550,6 +553,8 @@ Definition and (e1: expr) (e2: expr) := andimm n1 t2 | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) andimm n2 t1 + | and_case3 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) + Eop Oandn (t1:::t2:::Enil) | and_default e1 e2 => Eop Oand (e1:::e2:::Enil) end. @@ -611,6 +616,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) + | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. >> @@ -621,6 +627,7 @@ Inductive or_cases: forall (e1: expr) (e2: expr), Type := | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) | or_case4: forall n2 t2 n1 t1, or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) + | or_case5: forall t1 t2, or_cases ((Eop Onot (t1:::Enil))) (t2) | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. Definition or_match (e1: expr) (e2: expr) := @@ -629,6 +636,7 @@ Definition or_match (e1: expr) (e2: expr) := | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => or_case3 n1 t1 n2 t2 | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => or_case4 n2 t2 n1 t1 + | (Eop Onot (t1:::Enil)), t2 => or_case5 t1 t2 | e1, e2 => or_default e1 e2 end. @@ -642,6 +650,8 @@ Definition or (e1: expr) (e2: expr) := if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) | or_case4 n2 t2 n1 t1 => (* Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) *) if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) + | or_case5 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) + Eop Oorn (t1:::t2:::Enil) | or_default e1 e2 => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2878da1a..18234286 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -223,6 +223,7 @@ Nondetfunction and (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) | _, _ => Eop Oand (e1:::e2:::Enil) end. @@ -253,6 +254,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) + | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 26df4fc7..c81f6fb5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -430,6 +430,7 @@ Proof. red; intros until y; unfold and; case (and_match a b); intros; InvEval. - rewrite Val.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. + - (*andn*) TrivialExists; simpl; congruence. - TrivialExists. Qed. @@ -493,6 +494,7 @@ Proof. destruct (same_expr_pure t1 t2) eqn:?; auto. InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. + - (*orn*) TrivialExists; simpl; congruence. - apply DEFAULT. Qed. @@ -526,14 +528,14 @@ Theorem eval_notint: unary_constructor_sound notint Val.notint. Proof. assert (forall v, Val.lessdef (Val.notint (Val.notint v)) v). destruct v; simpl; auto. rewrite Int.not_involutive; auto. - unfold notint; red; intros until x; case (notint_match a); intros; InvEval. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists. + unfold notint; red; intros until x; case (notint_match a); intros; InvEval. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists. Qed. Theorem eval_divs_base: -- cgit From 92188c18a3761fa14dfdb97010cebe919548a010 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 18 Mar 2019 12:06:57 +0100 Subject: Idée de preuve VLIW MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingproof.v | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2e463f18..7d6d9a7a 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -658,8 +658,8 @@ Proof. eapply external_call_symbols_preserved; eauto. apply senv_preserved. Qed. -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). (* FIXME a remplacer par Asmvliw.semantics tprog *) +Theorem transf_program_correct_Asmblock: + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). Proof. eapply forward_simulation_plus. - apply senv_preserved. @@ -668,4 +668,23 @@ Proof. - apply transf_step_correct. Qed. +(* TODO: +Require Import Asmvliw. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). +Proof. + eapply forward_simulation_one_one. (* FIXME *) +Admitted. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmvliw.semantics tprog). +Proof. + eapply forward_simulation_compose. (* FIXME *) +Admitted. + +*) + + + End PRESERVATION. -- cgit From 6275ab1693a3cc13966dac53069d4cf9981e6200 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 13:01:54 +0100 Subject: some more andn / orn --- mppa_k1c/SelectOp.v | 20 ++++++++++++++++++++ mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 4 ++++ 3 files changed, 28 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index ada4ec2c..edb07e5f 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -493,6 +493,7 @@ Nondetfunction andimm (n1: int) (e2: expr) := else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oandnimm n1) (t2:::Enil) | _ => Eop (Oandimm n1) (e2:::Enil) end. >> @@ -501,12 +502,14 @@ Nondetfunction andimm (n1: int) (e2: expr) := Inductive andimm_cases: forall (e2: expr), Type := | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) + | andimm_case3: forall t2, andimm_cases (Eop Onot (t2:::Enil)) | andimm_default: forall (e2: expr), andimm_cases e2. Definition andimm_match (e2: expr) := match e2 as zz1 return andimm_cases zz1 with | Eop (Ointconst n2) Enil => andimm_case1 n2 | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 + | Eop Onot (t2:::Enil) => andimm_case3 t2 | e2 => andimm_default e2 end. @@ -516,6 +519,8 @@ Definition andimm (n1: int) (e2: expr) := Eop (Ointconst (Int.and n1 n2)) Enil | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | andimm_case3 t2 => (* Eop Onot (t2:::Enil) *) + Eop (Oandnimm n1) (t2:::Enil) | andimm_default e2 => Eop (Oandimm n1) (e2:::Enil) end. @@ -528,6 +533,7 @@ Nondetfunction and (e1: expr) (e2: expr) := | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 | t1, Eop (Ointconst n2) Enil => andimm n2 t1 | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) + | t1, (Eop Onot (t2:::Enil)) => Eop Oandn (t2:::t1:::Enil) | _, _ => Eop Oand (e1:::e2:::Enil) end. >> @@ -537,6 +543,7 @@ Inductive and_cases: forall (e1: expr) (e2: expr), Type := | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) | and_case3: forall t1 t2, and_cases ((Eop Onot (t1:::Enil))) (t2) + | and_case4: forall t1 t2, and_cases (t1) ((Eop Onot (t2:::Enil))) | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. Definition and_match (e1: expr) (e2: expr) := @@ -544,6 +551,7 @@ Definition and_match (e1: expr) (e2: expr) := | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 | (Eop Onot (t1:::Enil)), t2 => and_case3 t1 t2 + | t1, (Eop Onot (t2:::Enil)) => and_case4 t1 t2 | e1, e2 => and_default e1 e2 end. @@ -555,6 +563,8 @@ Definition and (e1: expr) (e2: expr) := andimm n2 t1 | and_case3 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) Eop Oandn (t1:::t2:::Enil) + | and_case4 t1 t2 => (* t1, (Eop Onot (t2:::Enil)) *) + Eop Oandn (t2:::t1:::Enil) | and_default e1 e2 => Eop Oand (e1:::e2:::Enil) end. @@ -568,6 +578,7 @@ Nondetfunction orimm (n1: int) (e2: expr) := else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oornimm n1) (t2:::Enil) | _ => Eop (Oorimm n1) (e2:::Enil) end. >> @@ -576,12 +587,14 @@ Nondetfunction orimm (n1: int) (e2: expr) := Inductive orimm_cases: forall (e2: expr), Type := | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) + | orimm_case3: forall t2, orimm_cases (Eop Onot (t2:::Enil)) | orimm_default: forall (e2: expr), orimm_cases e2. Definition orimm_match (e2: expr) := match e2 as zz1 return orimm_cases zz1 with | Eop (Ointconst n2) Enil => orimm_case1 n2 | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 + | Eop Onot (t2:::Enil) => orimm_case3 t2 | e2 => orimm_default e2 end. @@ -591,6 +604,8 @@ Definition orimm (n1: int) (e2: expr) := Eop (Ointconst (Int.or n1 n2)) Enil | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | orimm_case3 t2 => (* Eop Onot (t2:::Enil) *) + Eop (Oornimm n1) (t2:::Enil) | orimm_default e2 => Eop (Oorimm n1) (e2:::Enil) end. @@ -617,6 +632,7 @@ Nondetfunction or (e1: expr) (e2: expr) := then Eop (Ororimm n2) (t1:::Enil) 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 Oor (e1:::e2:::Enil) end. >> @@ -628,6 +644,7 @@ Inductive or_cases: forall (e1: expr) (e2: expr), Type := | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) | or_case4: forall n2 t2 n1 t1, or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) | or_case5: forall t1 t2, or_cases ((Eop Onot (t1:::Enil))) (t2) + | or_case6: forall t1 t2, or_cases (t1) ((Eop Onot (t2:::Enil))) | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. Definition or_match (e1: expr) (e2: expr) := @@ -637,6 +654,7 @@ Definition or_match (e1: expr) (e2: expr) := | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => or_case3 n1 t1 n2 t2 | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => or_case4 n2 t2 n1 t1 | (Eop Onot (t1:::Enil)), t2 => or_case5 t1 t2 + | t1, (Eop Onot (t2:::Enil)) => or_case6 t1 t2 | e1, e2 => or_default e1 e2 end. @@ -652,6 +670,8 @@ Definition or (e1: expr) (e2: expr) := if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) | or_case5 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) Eop Oorn (t1:::t2:::Enil) + | or_case6 t1 t2 => (* t1, (Eop Onot (t2:::Enil)) *) + Eop Oorn (t2:::t1:::Enil) | or_default e1 e2 => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 18234286..7ec694e2 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -216,6 +216,7 @@ Nondetfunction andimm (n1: int) (e2: expr) := else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oandnimm n1) (t2:::Enil) | _ => Eop (Oandimm n1) (e2:::Enil) end. @@ -224,6 +225,7 @@ Nondetfunction and (e1: expr) (e2: expr) := | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 | t1, Eop (Ointconst n2) Enil => andimm n2 t1 | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) + | t1, (Eop Onot (t2:::Enil)) => Eop Oandn (t2:::t1:::Enil) | _, _ => Eop Oand (e1:::e2:::Enil) end. @@ -233,6 +235,7 @@ Nondetfunction orimm (n1: int) (e2: expr) := else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oornimm n1) (t2:::Enil) | _ => Eop (Oorimm n1) (e2:::Enil) end. @@ -255,6 +258,7 @@ Nondetfunction or (e1: expr) (e2: expr) := then Eop (Ororimm n2) (t1:::Enil) 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 Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index c81f6fb5..57cd3d58 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -422,6 +422,7 @@ Proof. case (andimm_match a); intros. - InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. - InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + - InvEval. TrivialExists. simpl; congruence. - TrivialExists. Qed. @@ -431,6 +432,7 @@ Proof. - rewrite Val.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - (*andn*) TrivialExists; simpl; congruence. + - (*andn reverse*) rewrite Val.and_commut. TrivialExists; simpl; congruence. - TrivialExists. Qed. @@ -450,6 +452,7 @@ Proof. destruct (orimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.or_commut; auto. - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + - InvEval. TrivialExists. simpl; congruence. - TrivialExists. Qed. @@ -495,6 +498,7 @@ Proof. InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. 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. - apply DEFAULT. Qed. -- cgit From e55d69912ce45869fa446c7d98ed306a58c81a92 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 13:45:12 +0100 Subject: selection of andn/orn on long --- mppa_k1c/SelectLong.vp | 5 +++++ mppa_k1c/SelectLongproof.v | 5 +++++ 2 files changed, 10 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index dbd14b99..07ebf1a2 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -238,6 +238,7 @@ Nondetfunction andlimm (n1: int64) (e2: expr) := longconst (Int64.and n1 n2) | Eop (Oandlimm n2) (t2:::Enil) => Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | Eop Onotl (t2:::Enil) => Eop (Oandnlimm n1) (t2:::Enil) | _ => Eop (Oandlimm n1) (e2:::Enil) end. @@ -247,6 +248,8 @@ Nondetfunction andl (e1: expr) (e2: expr) := match e1, e2 with | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | (Eop Onotl (t1:::Enil)), t2 => Eop Oandnl (t1:::t2:::Enil) + | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) | _, _ => Eop Oandl (e1:::e2:::Enil) end. @@ -264,6 +267,8 @@ Nondetfunction orl (e1: expr) (e2: expr) := match e1, e2 with | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 | 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 Oorl (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 27052edc..27681875 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -382,6 +382,7 @@ Proof. - econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. - TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. - TrivialExists. +- TrivialExists. Qed. Theorem eval_andl: binary_constructor_sound andl Val.andl. @@ -390,6 +391,8 @@ Proof. red; intros. destruct (andl_match a b). - InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. - InvEval. apply eval_andlimm; auto. +- (*andn*) InvEval. TrivialExists. simpl. congruence. +- (*andn reverse*) InvEval. rewrite Val.andl_commut. TrivialExists; simpl. congruence. - TrivialExists. Qed. @@ -413,6 +416,8 @@ Proof. destruct (orl_match a b). - InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. - InvEval. apply eval_orlimm; auto. +- (*orn*) InvEval. TrivialExists; simpl; congruence. +- (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence. - TrivialExists. Qed. -- cgit From 6cd9c6faecaa830160fbca31924e29a5e791f499 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 13:56:32 +0100 Subject: andn / orn long complete I think --- mppa_k1c/Asmblockgen.v | 3 +++ 1 file changed, 3 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c3ac217b..87df237c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -547,6 +547,9 @@ Definition transl_op | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") (* Géré par fonction externe *) | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") (* Géré par fonction externe *) | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") (* Géré par fonction externe *) + | Onotl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs Int64.mone ::i k) | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 ::i k) -- cgit From eb814730ba3bc29ab7db69a5d6f46f172aff0152 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 15:15:16 +0100 Subject: begin implementing multiply-add --- mppa_k1c/Asm.v | 6 +++++- mppa_k1c/TargetPrinter.ml | 12 ++++++++++-- 2 files changed, 15 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 8486e25d..55143e4f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -148,6 +148,7 @@ Inductive instruction : Type := | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) | 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 *) @@ -163,6 +164,7 @@ Inductive instruction : Type := | 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 *) + | 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 *) @@ -187,6 +189,7 @@ Inductive instruction : Type := | 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 *) | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) @@ -202,7 +205,8 @@ Inductive instruction : Type := | 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 *) +. (** Correspondance between Asmblock and Asm *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index c3de5206..5c5d6c79 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -390,6 +390,8 @@ module Target (*: TARGET*) = fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psllw (rd, rs1, rs2) -> 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; fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -419,6 +421,8 @@ module Target (*: TARGET*) = fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psral (rd, rs1, rs2) -> 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 | Pfaddd (rd, rs1, rs2) -> fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -462,6 +466,8 @@ module Target (*: TARGET*) = fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint imm | Proriw (rd, rs, imm) -> fprintf oc " rorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pmaddiw (rd, rs, imm) -> + fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psllil (rd, rs, imm) -> fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm @@ -488,9 +494,11 @@ module Target (*: TARGET*) = | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandnil (rd, rs, imm) -> - fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint imm + fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pornil (rd, rs, imm) -> - fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint imm + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pmaddil (rd, rs, imm) -> + fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = -- cgit From 202050c6240a11c94cc8b6ab599022fee7bd2471 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 15:18:21 +0100 Subject: bug de pretty printing --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index c3de5206..511537ce 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -488,9 +488,9 @@ module Target (*: TARGET*) = | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandnil (rd, rs, imm) -> - fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint imm + fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pornil (rd, rs, imm) -> - fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint imm + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint64 imm let get_section_names name = let (text, lit) = -- cgit From aa400a9eed939578917810d32ef4fcf79944729d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 18 Mar 2019 16:13:22 +0100 Subject: The parent frame pointer is now R17 instead of R14 --- mppa_k1c/Asmblock.v | 5 +++-- mppa_k1c/Asmblockdeps.v | 4 ++-- mppa_k1c/Asmblockgen.v | 2 -- mppa_k1c/Asmblockgenproof.v | 4 ++-- mppa_k1c/Asmexpand.ml | 15 +++++---------- mppa_k1c/Machregs.v | 12 ++++++------ mppa_k1c/PostpassSchedulingproof.v | 6 +++--- 7 files changed, 21 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 5279bd29..4757b9fc 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -85,7 +85,8 @@ Module Pregmap := EMap(PregEq). (** Conventional names for stack pointer ([SP]) and return address ([RA]). *) Notation "'SP'" := GPR12 (only parsing) : asm. -Notation "'FP'" := GPR14 (only parsing) : asm. +Notation "'FP'" := GPR17 (only parsing) : asm. +Notation "'MFP'" := R17 (only parsing) : asm. Notation "'GPRA'" := GPR16 (only parsing) : asm. Notation "'RTMP'" := GPR32 (only parsing) : asm. @@ -1445,7 +1446,7 @@ Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 - | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | *) | R14 => GPR14 + | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c5b5bd56..b77fa47d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -750,7 +750,7 @@ Proof. rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. - destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. (* Freeframe *) - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rs GPR12) eqn:SPeq; try discriminate. destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv H0. @@ -758,7 +758,7 @@ Proof. * simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. Simpl. rewrite e. rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. (* Pget *) - simpl in H. destruct rs0 eqn:rs0eq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 9d682bed..f28102f8 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -25,8 +25,6 @@ Require Import Op Locations Machblock Asmblock. Local Open Scope string_scope. Local Open Scope error_monad_scope. -Notation "'MFP'" := R14 (only parsing). - (** 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 diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 84877488..ddc96f6c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -758,9 +758,9 @@ Qed. *) the unwanted behaviour. *) -Remark preg_of_not_FP: forall r, negb (mreg_eq r R14) = true -> IR FP <> preg_of r. +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 R14). red; intros. + intros. change (IR FP) with (preg_of MFP). red; intros. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index cd6cf1ec..22c424c1 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -401,16 +401,14 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in + emit (Pmv (Asmblock.GPR17, stack_pointer)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in - let full_sz = Z.add sz (Z.of_uint extra_sz) in begin - expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); - emit Psemi; - expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; - expand_addptrofs Asmblock.GPR14 stack_pointer (Ptrofs.repr full_sz) - end; + let full_sz = Z.add sz (Z.of_uint extra_sz) in + expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); emit Psemi; + expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; let va_ofs = sz in (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) @@ -419,9 +417,7 @@ let expand_instruction instr = end else begin expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); emit Psemi; - expand_storeind_ptr Asmblock.GPR14 stack_pointer ofs; - expand_addptrofs Asmblock.GPR14 stack_pointer (Ptrofs.repr sz); - emit Psemi; + expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> @@ -431,7 +427,6 @@ let expand_instruction instr = let n = arguments_size sg in if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) end else 0 in - expand_loadind_ptr Asmblock.GPR14 stack_pointer ofs; expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) (*| Pseqw(rd, rs1, rs2) -> diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 1c1930da..28154c7f 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -41,7 +41,7 @@ Require Import Op. Inductive mreg: Type := (* Allocatable General Purpose regs. *) | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 - | R10 | R11 | (* R12 | R13 | *) R14 | R15 (* | R16 *) | R17 | R18 | R19 + | R10 | R11 (* | R12 | R13 | R14 *) | R15 (* | R16 *) | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 (* | R32 *) | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 @@ -54,7 +54,7 @@ Global Opaque mreg_eq. Definition all_mregs := R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 - :: R10 :: R11 (* :: R12 :: R13 *) :: R14 :: R15 (* :: R16 *) :: R17 :: R18 :: R19 + :: R10 :: R11 (* :: R12 :: R13 :: R14 *) :: R15 (* :: R16 *) :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 @@ -86,7 +86,7 @@ Module IndexedMreg <: INDEXED_TYPE. match r with | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 - | R10 => 11 | R11 => 12 (* | R12 => 13 | R13 => 14 *) | R14 => 15 + | R10 => 11 | R11 => 12 (* | R12 => 13 | R13 => 14 | R14 => 15 *) | R15 => 16 (* | R16 => 17 *) | R17 => 18 | R18 => 19 | R19 => 20 | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 @@ -115,7 +115,7 @@ Local Open Scope string_scope. Definition register_names := ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R8" , R8) :: ("R9" , R9) - :: ("R10", R10) :: ("R11", R11) (* :: ("R12", R12) :: ("R13", R13) *) :: ("R14", R14) + :: ("R10", R10) :: ("R11", R11) (* :: ("R12", R12) :: ("R13", R13) :: ("R14", R14) *) :: ("R15", R15) (* :: ("R16", R16) *) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) @@ -174,9 +174,9 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := Definition destroyed_by_setstack (ty: typ): list mreg := nil. -Definition destroyed_at_function_entry: list mreg := R14 :: nil. +Definition destroyed_at_function_entry: list mreg := R17 :: nil. -Definition temp_for_parent_frame: mreg := R14. (* FIXME - ?? *) +Definition temp_for_parent_frame: mreg := R17. (* Temporary used to store the parent frame, where the arguments are *) Definition destroyed_at_indirect_call: list mreg := nil. (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2de49faa..33912203 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -67,8 +67,8 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -Lemma next_eq {A: Type}: - forall (rs rs':A) m m', +Lemma next_eq: + forall (rs rs': regset) m m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. Proof. intros. congruence. @@ -136,7 +136,7 @@ Proof. 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 GPR14 PC); try discriminate. reflexivity. + 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. -- cgit From 652a59174685ef4d4333a56812e2c30041828c16 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 18:35:31 +0100 Subject: ça passe mais pas encore l'oracle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 10 ++++++++++ mppa_k1c/Asmblock.v | 38 ++++++++++++++++++++++++++++++++++++ mppa_k1c/Asmblockdeps.v | 51 ++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 98 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 55143e4f..1a57e554 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -347,6 +347,16 @@ Definition basic_to_instruction (b: basic) := | PArithRRI64 Asmblock.Pandnil rd rs imm => Pandnil rd rs imm | PArithRRI64 Asmblock.Pornil rd rs imm => Pornil rd rs imm + (** ARRR *) + | PArithARRR Asmblock.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmblock.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + + (** ARRI32 *) + | PArithARRI32 Asmblock.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmblock.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + (** Load *) | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra ofs diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cdbe4eb3..9b51ea33 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -406,6 +406,19 @@ Inductive arith_name_rri64 : Type := | Pornil (**r orn immediate long *) . +Inductive arith_name_arrr : Type := + | Pmaddw (**r multiply add word *) + | Pmaddl (**r multiply add long *) +. + +Inductive arith_name_arri32 : Type := + | Pmaddiw (**r multiply add word *) +. + +Inductive arith_name_arri64 : Type := + | Pmaddil (**r multiply add long *) +. + Inductive ar_instruction : Type := | PArithR (i: arith_name_r) (rd: ireg) | PArithRR (i: arith_name_rr) (rd rs: ireg) @@ -416,6 +429,9 @@ Inductive ar_instruction : Type := | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) + | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) + | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) + | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) . Coercion PArithR: arith_name_r >-> Funclass. @@ -1180,6 +1196,22 @@ Definition arith_eval_rri64 n v i := | Pornil => Val.orl (Val.notl v) (Vlong i) 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) + end. + +Definition arith_eval_arri32 n v1 v2 v3 := + match n with + | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) + end. + +Definition arith_eval_arri64 n v1 v2 v3 := + match n with + | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) + end. + Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := match ai with | PArithR n d => rs#d <- (arith_eval_r n) @@ -1196,6 +1228,12 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := | PArithRRI32 n d s i => rs#d <- (arith_eval_rri32 n rs#s i) | PArithRRI64 n d s i => rs#d <- (arith_eval_rri64 n rs#s i) + + | PArithARRR n d s1 s2 => rs#d <- (arith_eval_arrr n rs#d rs#s1 rs#s2) + + | PArithARRI32 n d s i => rs#d <- (arith_eval_arri32 n rs#d rs#s i) + + | PArithARRI64 n d s i => rs#d <- (arith_eval_arri64 n rs#d rs#s i) end. (** * load/store *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index d69903b4..5a138d00 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -52,6 +52,9 @@ Inductive arith_op := | OArithRRR (n: arith_name_rrr) | OArithRRI32 (n: arith_name_rri32) (imm: int) | OArithRRI64 (n: arith_name_rri64) (imm: int64) + | OArithARRR (n: arith_name_arrr) + | OArithARRI32 (n: arith_name_arri32) (imm: int) + | OArithARRI64 (n: arith_name_arri64) (imm: int64) . Coercion OArithR: arith_name_r >-> arith_op. @@ -109,10 +112,13 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRF64 n i, [] => Some (Val (arith_eval_rf64 n i)) | OArithRRR n, [Val v1; Val v2] => Some (Val (arith_eval_rrr n v1 v2)) - | OArithRRI32 n i, [Val v] => Some (Val (arith_eval_rri32 n v i)) | OArithRRI64 n i, [Val v] => Some (Val (arith_eval_rri64 n v i)) + | OArithARRR n, [Val v1; Val v2; Val v3] => Some (Val (arith_eval_arrr n v1 v2 v3)) + | OArithARRI32 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri32 n v1 v2 i)) + | OArithARRI64 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri64 n v1 v2 i)) + | _, _ => None end. @@ -525,6 +531,9 @@ Definition trans_arith (ai: ar_instruction) : macro := | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] + | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (Name(#d) @ Name (#s1) @ Name (#s2) @ Enil))] + | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (Name(#d) @ Name (#s) @ Enil))] + | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (Name(#d) @ Name (#s) @ Enil))] end. @@ -711,6 +720,27 @@ Proof. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRR *) + - inv H; inv H0; + eexists; split; try split. + * simpl. pose (H1 rd); rewrite e. pose (H1 rs1); rewrite e0. pose (H1 rs2); rewrite e1. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRI32 *) + - inv H; inv H0; + eexists; split; try split. + * simpl. pose (H1 rd); rewrite e. pose (H1 rs0); rewrite e0. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRI64 *) + - inv H; inv H0; + eexists; split; try split. + * simpl. pose (H1 rd); rewrite e. pose (H1 rs0); rewrite e0. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. Qed. Lemma forward_simu_basic: @@ -1367,6 +1397,22 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := | Pornil => "Pornil" end. +Definition string_of_name_arrr (n: arith_name_arrr): pstring := + match n with + | Pmaddw => "Pmaddw" + | Pmaddl => "Pmaddl" + end. + +Definition string_of_name_arri32 (n: arith_name_arri32): pstring := + match n with + | Pmaddiw => "Pmaddw" + end. + +Definition string_of_name_arri64 (n: arith_name_arri64): pstring := + match n with + | Pmaddil => "Pmaddl" + end. + Definition string_of_arith (op: arith_op): pstring := match op with | OArithR n => string_of_name_r n @@ -1378,6 +1424,9 @@ Definition string_of_arith (op: arith_op): pstring := | OArithRRR n => string_of_name_rrr n | OArithRRI32 n _ => string_of_name_rri32 n | OArithRRI64 n _ => string_of_name_rri64 n + | OArithARRR n => string_of_name_arrr n + | OArithARRI32 n _ => string_of_name_arri32 n + | OArithARRI64 n _ => string_of_name_arri64 n end. Definition string_of_name_lrro (n: load_name_rro) : pstring := -- cgit From fe4318192bb29fa25dc163004701a45879c41ec0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 18:57:08 +0100 Subject: maddw exists now in postpass scheduler --- mppa_k1c/PostpassSchedulingOracle.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ce2fb2ae..22833dfd 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -123,6 +123,10 @@ let arith_rri64_str = function | Pandnil -> "Pandnil" | Pornil -> "Pornil" +let arith_arrr_str = function + | Pmaddw -> "Pmaddw" + | Pmaddl -> "Pmaddl" + let arith_ri32_str = "Pmake" let arith_ri64_str = "Pmakel" @@ -162,6 +166,12 @@ let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Re 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_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_r_rec i rd = match i with @@ -173,6 +183,10 @@ let arith_rec i = | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) + (* 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)) + | 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 = []; -- cgit From ea12bb63c4ff63c12a383b8b66dff11fc5dc6e65 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 20:50:02 +0100 Subject: plus d'infrastructure pour madd --- mppa_k1c/NeedOp.v | 6 ++++++ mppa_k1c/Op.v | 41 +++++++++++++++++++++++++++++++++++++++++ mppa_k1c/ValueAOp.v | 2 ++ 3 files changed, 49 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 12d7a4f7..801a520e 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -25,6 +25,7 @@ Require Import NeedDomain. Definition op1 (nv: nval) := nv :: nil. Definition op2 (nv: nval) := nv :: nv :: nil. +Definition op3 (nv: nval) := nv :: nv :: nv :: nil. Definition needs_of_condition (cond: condition): list nval := nil. @@ -68,6 +69,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ororimm n => op1 (ror nv n) | Oshruimm n => op1 (shruimm nv n) | Oshrximm n => op1 (default nv) + | Omadd => op3 (modarith nv) + | Omaddimm n => op2 (modarith nv) | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocast32signed => op1 (default nv) @@ -189,6 +192,9 @@ Proof. - apply shrimm_sound; auto. - apply shruimm_sound; auto. - apply ror_sound; auto. + (* 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. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 04ea8945..c56a9649 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -101,6 +101,8 @@ Inductive operation : Type := | Oshruimm (n: int) (**r [rd = r1 >> 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] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -142,6 +144,10 @@ Inductive operation : Type := | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) + (* FIXME + | Omaddl (**r [rd = rd + r1 * r2] *) + | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) +*) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -293,6 +299,9 @@ Definition eval_operation | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) | 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))) + | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) | Ohighlong, v1::nil => Some (Val.hiword v1) @@ -333,6 +342,12 @@ Definition eval_operation | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) | 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))) + *) + | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) @@ -472,6 +487,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshruimm _ => (Tint :: nil, Tint) | Oshrximm _ => (Tint :: nil, Tint) | Ororimm _ => (Tint :: nil, Tint) + | Omadd => (Tint :: Tint :: Tint :: nil, Tint) + | Omaddimm _ => (Tint :: Tint :: nil, Tint) + | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) | Ohighlong => (Tlong :: nil, Tint) @@ -512,6 +530,10 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshrlu => (Tlong :: Tint :: nil, Tlong) | Oshrluimm _ => (Tlong :: nil, Tlong) | Oshrxlimm _ => (Tlong :: nil, Tlong) + (* FIXME + | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) +*) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) @@ -654,6 +676,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... (* shrimm *) - destruct v0; simpl... + (* madd *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1... (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -720,6 +745,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... (* shrxl *) - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + (* FIXME + (* maddl, maddlim *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1... *) (* negf, absf *) - destruct v0... - destruct v0... @@ -1153,6 +1182,9 @@ Proof. destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. (* rorimm *) - inv H4; simpl; auto. + (* madd, maddim *) + - inv H2; inv H3; inv H4; simpl; auto. + - inv H2; inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1222,6 +1254,15 @@ Proof. (* shrx *) - inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + + (* + (* maddl, maddlim *) + - inv H2; inv H3; inv H4; simpl; auto; simpl. + destruct Archi.ptr64; trivial. + s + - inv H2; inv H4; simpl; auto. + *) + (* negf, absf *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 57676b35..a92358ca 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -88,6 +88,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshru, v1::v2::nil => shru v1 v2 | Oshruimm n, v1::nil => shru v1 (I n) | 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)) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 -- cgit From ddbe4221279f9e75b4ed075156420e62a92f28d9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 22:08:45 +0100 Subject: maddw dans la génération MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 3 +++ mppa_k1c/Asmblockgen.v | 7 ++++++- 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9b51ea33..b3e1532d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -443,6 +443,9 @@ Coercion PArithRF64: arith_name_rf64 >-> Funclass. Coercion PArithRRR: arith_name_rrr >-> Funclass. Coercion PArithRRI32: arith_name_rri32 >-> Funclass. Coercion PArithRRI64: arith_name_rri64 >-> Funclass. +Coercion PArithARRR: arith_name_arrr >-> Funclass. +Coercion PArithARRI32: arith_name_arri32 >-> Funclass. +Coercion PArithARRI64: arith_name_arri64 >-> Funclass. Inductive basic : Type := | PArith (i: ar_instruction) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 87df237c..1646ff94 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -513,7 +513,12 @@ Definition transl_op | Ororimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Proriw rd rs n ::i k) - + | Omadd, 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 (Pmaddw r1 r2 r3 ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; -- cgit From a34c36161ac7bd43e128a39aaf52c15c5f923400 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 18 Mar 2019 23:25:04 +0100 Subject: mandw mais ça coince MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingOracle.ml | 11 ++++++++--- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 2 ++ 3 files changed, 12 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 22833dfd..b02bc6ca 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -413,6 +413,7 @@ type real_instruction = | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd + | Maddw | Maddd | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -450,6 +451,7 @@ let ab_inst_to_real = function | "Psrll" | "Psrlil" -> Srld | "Psllw" | "Pslliw" -> Sllw | "Proriw" -> Rorw + | "Pmaddw" -> Maddw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pnxorw" | "Pnxoriw" -> Nxorw @@ -459,6 +461,7 @@ let ab_inst_to_real = function | "Pnxorl" | "Pnxoril" -> Nxord | "Pandnl" | "Pandnil" -> Andnd | "Pornl" | "Pornil" -> Ornd + | "Pmaddl" -> Maddd | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Psxwd" -> Sxwd @@ -520,11 +523,13 @@ let rec_to_usage r = (* I do not know yet in which context Ofslow can be used by CompCert *) and real_inst = ab_inst_to_real r.inst in match real_inst with - | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw | Nxorw | Andnw | Ornw -> + | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw + | Nxorw | Andnw | Ornw | Maddw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) - | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord | Nxord | Andnd | Ornd -> + | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord + | Nxord | Andnd | Ornd | Maddd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) @@ -580,7 +585,7 @@ let real_inst_to_latency = function | Sxwd | Zxwd | Fcompw | Fcompd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 - | Mulw | Muld -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) + | Mulw | Muld | Maddw | Maddd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> 3 | Sb | Sh | Sw | Sd -> 1 (* See k1c-Optimization.pdf page 19 *) | Get -> 1 diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 7ec694e2..e34e7c32 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -86,6 +86,8 @@ Nondetfunction add (e1: expr) (e2: expr) := addimm n1 (Eop Oadd (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + Eop Omadd (t1:::t2:::t3:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 57cd3d58..d7ae92dc 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -182,6 +182,8 @@ Proof. with (Val.add (Val.add x v1) (Vint n2)). apply eval_addimm. EvalOp. repeat rewrite Val.add_assoc. reflexivity. + - (* Omadd *) + subst. TrivialExists. - TrivialExists. Qed. -- cgit From fdb8d0c7b5a8be87a64cb995f3abf5bc60f07bfd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 07:07:46 +0100 Subject: implemented -fno-postpass normally --- mppa_k1c/Asmgen.v | 5 ++++- mppa_k1c/Asmgenproof.v | 52 +++++++++++++++++++++++++++++++++----------------- mppa_k1c/SelectOp.v | 6 ++++++ 3 files changed, 45 insertions(+), 18 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 58e80be1..46714496 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -19,13 +19,16 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. Require Import Errors. +Require Import Compopts. Local Open Scope error_monad_scope. 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; + do abp' <- if Compopts.optim_postpass tt + then PostpassScheduling.transf_program abp + else OK abp; OK (Asm.transf_program abp'). Definition transf_function (f: Mach.function) : res Asm.function := diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 588019a2..918403cd 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -17,15 +17,18 @@ Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. Require Import Machblockgenproof Asmblockgenproof PostpassSchedulingproof. +Require Import Compopts. Local Open Scope linking_scope. Definition block_passes := mkpass Machblockgenproof.match_prog ::: mkpass Asmblockgenproof.match_prog - ::: mkpass PostpassSchedulingproof.match_prog - ::: mkpass Asm.match_prog - ::: pass_nil _. + ::: if Compopts.optim_postpass tt + then mkpass PostpassSchedulingproof.match_prog + ::: mkpass Asm.match_prog + ::: pass_nil _ + else mkpass Asm.match_prog ::: pass_nil _. Definition match_prog := pass_match (compose_passes block_passes). @@ -36,11 +39,16 @@ Proof. 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. - unfold match_prog; simpl. - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. - exists x; split. apply Asmblockgenproof.transf_program_match; auto. - exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. - exists tp; split. apply Asm.transf_program_match; auto. auto. + unfold match_prog. simpl. + destruct (optim_postpass tt); simpl. + - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x; split. apply Asmblockgenproof.transf_program_match; auto. + exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. + exists tp; split. apply Asm.transf_program_match; auto. auto. + - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x0; split. apply Asmblockgenproof.transf_program_match; auto. + congruence. + exists tp; split. apply Asm.transf_program_match; auto. auto. Qed. (** Return Address Offset *) @@ -149,15 +157,25 @@ Let tge := Genv.globalenv tprog. Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. - unfold match_prog in TRANSF. simpl in TRANSF. - inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. - eapply compose_forward_simulations. - exploit Machblockgenproof.transf_program_correct; eauto. - unfold Machblockgenproof.inv_trans_rao. - intros X; apply X. - eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. - eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. - apply Asm.transf_program_correct. eauto. + unfold match_prog in TRANSF. + simpl in TRANSF. + inv TRANSF. + destruct (optim_postpass tt) in *. + - inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. inv H4. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + intros X; apply X. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. + apply Asm.transf_program_correct; eauto. + - inv H. inv H1. inv H. inv H2. inv H. inv H3. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + intros X; apply X. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + apply Asm.transf_program_correct ; eauto. Qed. End PRESERVATION. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index edb07e5f..66615f1d 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -123,6 +123,8 @@ Nondetfunction add (e1: expr) (e2: expr) := addimm n1 (Eop Oadd (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + Eop Omadd (t1:::t2:::t3:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. >> @@ -136,6 +138,7 @@ Inductive add_cases: forall (e1: expr) (e2: expr), Type := | add_case5: forall n1 n2 t2, add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) | add_case6: forall n1 t1 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) | add_case7: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case8: forall t1 t2 t3, add_cases (t1) ((Eop Omul (t2:::t3:::Enil))) | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. Definition add_match (e1: expr) (e2: expr) := @@ -147,6 +150,7 @@ Definition add_match (e1: expr) (e2: expr) := | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => add_case5 n1 n2 t2 | Eop (Oaddimm n1) (t1:::Enil), t2 => add_case6 n1 t1 t2 | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case7 t1 n2 t2 + | t1, (Eop Omul (t2:::t3:::Enil)) => add_case8 t1 t2 t3 | e1, e2 => add_default e1 e2 end. @@ -166,6 +170,8 @@ Definition add (e1: expr) (e2: expr) := addimm n1 (Eop Oadd (t1:::t2:::Enil)) | add_case7 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | add_case8 t1 t2 t3 => (* t1, (Eop Omul (t2:::t3:::Enil)) *) + Eop Omadd (t1:::t2:::t3:::Enil) | add_default e1 e2 => Eop Oadd (e1:::e2:::Enil) end. -- cgit From b74e3c48e601e46cb695caccc162cd03e781d739 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Mar 2019 10:14:35 +0100 Subject: Psemi manquant dans l'expansion de Pallocframe --- mppa_k1c/Asmexpand.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 22c424c1..1c9e4e4c 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -409,6 +409,7 @@ let expand_instruction instr = expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); emit Psemi; expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; + emit Psemi; let va_ofs = sz in (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) @@ -418,6 +419,7 @@ let expand_instruction instr = expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); emit Psemi; expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; + emit Psemi; vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> -- cgit From 6d2c27127fd67b6ad5499c7d3f4be537333ac356 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 13:31:57 +0100 Subject: Revert "implemented -fno-postpass normally" This reverts commit fdb8d0c7b5a8be87a64cb995f3abf5bc60f07bfd. --- mppa_k1c/Asmgen.v | 5 +---- mppa_k1c/Asmgenproof.v | 52 +++++++++++++++++--------------------------------- mppa_k1c/SelectOp.v | 6 ------ 3 files changed, 18 insertions(+), 45 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 46714496..58e80be1 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -19,16 +19,13 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. Require Import Errors. -Require Import Compopts. Local Open Scope error_monad_scope. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := Machblockgen.transf_program p in do abp <- Asmblockgen.transf_program mbp; - do abp' <- if Compopts.optim_postpass tt - then PostpassScheduling.transf_program abp - else OK abp; + do abp' <- PostpassScheduling.transf_program abp; OK (Asm.transf_program abp'). Definition transf_function (f: Mach.function) : res Asm.function := diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 918403cd..588019a2 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -17,18 +17,15 @@ Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. Require Import Machblockgenproof Asmblockgenproof PostpassSchedulingproof. -Require Import Compopts. Local Open Scope linking_scope. Definition block_passes := mkpass Machblockgenproof.match_prog ::: mkpass Asmblockgenproof.match_prog - ::: if Compopts.optim_postpass tt - then mkpass PostpassSchedulingproof.match_prog - ::: mkpass Asm.match_prog - ::: pass_nil _ - else mkpass Asm.match_prog ::: pass_nil _. + ::: mkpass PostpassSchedulingproof.match_prog + ::: mkpass Asm.match_prog + ::: pass_nil _. Definition match_prog := pass_match (compose_passes block_passes). @@ -39,16 +36,11 @@ Proof. 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. - unfold match_prog. simpl. - destruct (optim_postpass tt); simpl. - - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. - exists x; split. apply Asmblockgenproof.transf_program_match; auto. - exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. - exists tp; split. apply Asm.transf_program_match; auto. auto. - - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. - exists x0; split. apply Asmblockgenproof.transf_program_match; auto. - congruence. - exists tp; split. apply Asm.transf_program_match; auto. auto. + unfold match_prog; simpl. + exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x; split. apply Asmblockgenproof.transf_program_match; auto. + exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. + exists tp; split. apply Asm.transf_program_match; auto. auto. Qed. (** Return Address Offset *) @@ -157,25 +149,15 @@ Let tge := Genv.globalenv tprog. Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. - unfold match_prog in TRANSF. - simpl in TRANSF. - inv TRANSF. - destruct (optim_postpass tt) in *. - - inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. inv H4. - eapply compose_forward_simulations. - exploit Machblockgenproof.transf_program_correct; eauto. - unfold Machblockgenproof.inv_trans_rao. - intros X; apply X. - eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. - eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. - apply Asm.transf_program_correct; eauto. - - inv H. inv H1. inv H. inv H2. inv H. inv H3. - eapply compose_forward_simulations. - exploit Machblockgenproof.transf_program_correct; eauto. - unfold Machblockgenproof.inv_trans_rao. - intros X; apply X. - eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. - apply Asm.transf_program_correct ; eauto. + unfold match_prog in TRANSF. simpl in TRANSF. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + intros X; apply X. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. + apply Asm.transf_program_correct. eauto. Qed. End PRESERVATION. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index 66615f1d..edb07e5f 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -123,8 +123,6 @@ Nondetfunction add (e1: expr) (e2: expr) := addimm n1 (Eop Oadd (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | t1, (Eop Omul (t2:::t3:::Enil)) => - Eop Omadd (t1:::t2:::t3:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. >> @@ -138,7 +136,6 @@ Inductive add_cases: forall (e1: expr) (e2: expr), Type := | add_case5: forall n1 n2 t2, add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) | add_case6: forall n1 t1 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) | add_case7: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case8: forall t1 t2 t3, add_cases (t1) ((Eop Omul (t2:::t3:::Enil))) | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. Definition add_match (e1: expr) (e2: expr) := @@ -150,7 +147,6 @@ Definition add_match (e1: expr) (e2: expr) := | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => add_case5 n1 n2 t2 | Eop (Oaddimm n1) (t1:::Enil), t2 => add_case6 n1 t1 t2 | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case7 t1 n2 t2 - | t1, (Eop Omul (t2:::t3:::Enil)) => add_case8 t1 t2 t3 | e1, e2 => add_default e1 e2 end. @@ -170,8 +166,6 @@ Definition add (e1: expr) (e2: expr) := addimm n1 (Eop Oadd (t1:::t2:::Enil)) | add_case7 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_case8 t1 t2 t3 => (* t1, (Eop Omul (t2:::t3:::Enil)) *) - Eop Omadd (t1:::t2:::t3:::Enil) | add_default e1 e2 => Eop Oadd (e1:::e2:::Enil) end. -- cgit From 08136431cae04e29491c22be1a45c3b7171c232b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 14:14:49 +0100 Subject: specify instructions that write to first operand (madd) --- mppa_k1c/Machregs.v | 2 +- mppa_k1c/SelectOp.v | 1323 --------------------------------------------------- 2 files changed, 1 insertion(+), 1324 deletions(-) delete mode 100644 mppa_k1c/SelectOp.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 1c1930da..9f0f6a4d 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -210,7 +210,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned => true + | Ocast32unsigned | Omadd | Omaddimm _ => true | _ => false end. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v deleted file mode 100644 index edb07e5f..00000000 --- a/mppa_k1c/SelectOp.v +++ /dev/null @@ -1,1323 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Archi. -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. - -Local Open Scope cminorsel_scope. - -(** ** Constants **) - -Definition addrsymbol (id: ident) (ofs: ptrofs) := - Eop (Oaddrsymbol id ofs) Enil. - -Definition addrstack (ofs: ptrofs) := - Eop (Oaddrstack ofs) Enil. - -(** ** Integer addition and pointer addition *) - -(** Original definition: -<< -Nondetfunction addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil - | Eop (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 (Oaddimm n) (e ::: Enil) - end. ->> -*) - -Inductive addimm_cases: forall (e: expr), Type := - | addimm_case1: forall m, addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: forall s m, addimm_cases (Eop (Oaddrsymbol s m) Enil) - | addimm_case3: forall m, addimm_cases (Eop (Oaddrstack m) Enil) - | addimm_case4: forall m t, addimm_cases (Eop (Oaddimm m) (t ::: Enil)) - | addimm_default: forall (e: expr), addimm_cases e. - -Definition addimm_match (e: expr) := - match e as zz1 return addimm_cases zz1 with - | Eop (Ointconst m) Enil => addimm_case1 m - | Eop (Oaddrsymbol s m) Enil => addimm_case2 s m - | Eop (Oaddrstack m) Enil => addimm_case3 m - | Eop (Oaddimm m) (t ::: Enil) => addimm_case4 m t - | e => addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else match addimm_match e with - | addimm_case1 m => (* Eop (Ointconst m) Enil *) - Eop (Ointconst (Int.add n m)) Enil - | addimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) - Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil - | addimm_case3 m => (* Eop (Oaddrstack m) Enil *) - Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil - | addimm_case4 m t => (* Eop (Oaddimm m) (t ::: Enil) *) - Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | addimm_default e => - Eop (Oaddimm n) (e ::: Enil) - end. - - -(** Original definition: -<< -Nondetfunction add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => - Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) - | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => - Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) - | Eop (Oaddimm n1) (t1:::Enil), t2 => - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | _, _ => Eop Oadd (e1:::e2:::Enil) - end. ->> -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Type := - | add_case1: forall n1 t2, add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: forall t1 n2, add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case3: forall n1 t1 n2 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case4: forall n1 t1 n2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) - | add_case5: forall n1 n2 t2, add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case6: forall n1 t1 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | add_case7: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return add_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => add_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => add_case2 t1 n2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => add_case3 n1 t1 n2 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => add_case4 n1 t1 n2 - | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => add_case5 n1 n2 t2 - | Eop (Oaddimm n1) (t1:::Enil), t2 => add_case6 n1 t1 t2 - | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case7 t1 n2 t2 - | e1, e2 => add_default e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - addimm n1 t2 - | add_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - addimm n2 t1 - | add_case3 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | add_case4 n1 t1 n2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) - Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) - | add_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) *) - Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) - | add_case6 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | add_case7 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_default e1 e2 => - Eop Oadd (e1:::e2:::Enil) - end. - - -(** ** Integer and pointer subtraction *) - -(** Original definition: -<< -Nondetfunction sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => - addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. ->> -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Type := - | sub_case1: forall t1 n2, sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: forall n1 t1 n2 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case3: forall n1 t1 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | sub_case4: forall t1 n2 t2, sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_default: forall (e1: expr) (e2: expr), sub_cases e1 e2. - -Definition sub_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return sub_cases zz1 zz2 with - | t1, Eop (Ointconst n2) Enil => sub_case1 t1 n2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => sub_case2 n1 t1 n2 t2 - | Eop (Oaddimm n1) (t1:::Enil), t2 => sub_case3 n1 t1 t2 - | t1, Eop (Oaddimm n2) (t2:::Enil) => sub_case4 t1 n2 t2 - | e1, e2 => sub_default e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction negint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil - | _ => Eop Oneg (e ::: Enil) - end. ->> -*) - -Inductive negint_cases: forall (e: expr), Type := - | negint_case1: forall n, negint_cases (Eop (Ointconst n) Enil) - | negint_default: forall (e: expr), negint_cases e. - -Definition negint_match (e: expr) := - match e as zz1 return negint_cases zz1 with - | Eop (Ointconst n) Enil => negint_case1 n - | e => negint_default e - end. - -Definition negint (e: expr) := - match negint_match e with - | negint_case1 n => (* Eop (Ointconst n) Enil *) - Eop (Ointconst (Int.neg n)) Enil - | negint_default e => - Eop Oneg (e ::: Enil) - end. - - -(** ** Immediate shifts *) - -(** Original definition: -<< -Nondetfunction shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shl n1 n)) Enil - | Eop (Oshlimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshlimm n) (e1:::Enil) - | _ => - Eop (Oshlimm n) (e1:::Enil) - end. ->> -*) - -Inductive shlimm_cases: forall (e1: expr) , Type := - | shlimm_case1: forall n1, shlimm_cases (Eop (Ointconst n1) Enil) - | shlimm_case2: forall n1 t1, shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) - | shlimm_default: forall (e1: expr) , shlimm_cases e1. - -Definition shlimm_match (e1: expr) := - match e1 as zz1 return shlimm_cases zz1 with - | Eop (Ointconst n1) Enil => shlimm_case1 n1 - | Eop (Oshlimm n1) (t1:::Enil) => shlimm_case2 n1 t1 - | e1 => shlimm_default e1 - end. - -Definition shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shlimm_match e1 with - | shlimm_case1 n1 => (* Eop (Ointconst n1) Enil *) - Eop (Ointconst (Int.shl n1 n)) Enil - | shlimm_case2 n1 t1 => (* Eop (Oshlimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) - | shlimm_default e1 => - Eop (Oshlimm n) (e1:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shru n1 n)) Enil - | Eop (Oshruimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshruimm n) (e1:::Enil) - | _ => - Eop (Oshruimm n) (e1:::Enil) - end. ->> -*) - -Inductive shruimm_cases: forall (e1: expr) , Type := - | shruimm_case1: forall n1, shruimm_cases (Eop (Ointconst n1) Enil) - | shruimm_case2: forall n1 t1, shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) - | shruimm_default: forall (e1: expr) , shruimm_cases e1. - -Definition shruimm_match (e1: expr) := - match e1 as zz1 return shruimm_cases zz1 with - | Eop (Ointconst n1) Enil => shruimm_case1 n1 - | Eop (Oshruimm n1) (t1:::Enil) => shruimm_case2 n1 t1 - | e1 => shruimm_default e1 - end. - -Definition shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shruimm_match e1 with - | shruimm_case1 n1 => (* Eop (Ointconst n1) Enil *) - Eop (Ointconst (Int.shru n1 n)) Enil - | shruimm_case2 n1 t1 => (* Eop (Oshruimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) - | shruimm_default e1 => - Eop (Oshruimm n) (e1:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shr n1 n)) Enil - | Eop (Oshrimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrimm n) (e1:::Enil) - | _ => - Eop (Oshrimm n) (e1:::Enil) - end. ->> -*) - -Inductive shrimm_cases: forall (e1: expr) , Type := - | shrimm_case1: forall n1, shrimm_cases (Eop (Ointconst n1) Enil) - | shrimm_case2: forall n1 t1, shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) - | shrimm_default: forall (e1: expr) , shrimm_cases e1. - -Definition shrimm_match (e1: expr) := - match e1 as zz1 return shrimm_cases zz1 with - | Eop (Ointconst n1) Enil => shrimm_case1 n1 - | Eop (Oshrimm n1) (t1:::Enil) => shrimm_case2 n1 t1 - | e1 => shrimm_default e1 - end. - -Definition shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shrimm_match e1 with - | shrimm_case1 n1 => (* Eop (Ointconst n1) Enil *) - Eop (Ointconst (Int.shr n1 n)) Enil - | shrimm_case2 n1 t1 => (* Eop (Oshrimm n1) (t1:::Enil) *) - if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) - | shrimm_default e1 => - Eop (Oshrimm n) (e1:::Enil) - end. - - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) - | _ => - Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) - end. - -(** Original definition: -<< -Nondetfunction mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. ->> -*) - -Inductive mulimm_cases: forall (e2: expr), Type := - | mulimm_case1: forall n2, mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: forall n2 t2, mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) - | mulimm_default: forall (e2: expr), mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as zz1 return mulimm_cases zz1 with - | Eop (Ointconst n2) Enil => mulimm_case1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => mulimm_case2 n2 t2 - | e2 => mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.one then e2 else match mulimm_match e2 with - | mulimm_case1 n2 => (* Eop (Ointconst n2) Enil *) - Eop (Ointconst (Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => (* Eop (Oaddimm n2) (t2:::Enil) *) - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - - -(** Original definition: -<< -Nondetfunction mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. ->> -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Type := - | mul_case1: forall n1 t2, mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: forall t1 n2, mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: forall (e1: expr) (e2: expr), mul_cases e1 e2. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return mul_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => mul_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => mul_case2 t1 n2 - | e1, e2 => mul_default e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - mulimm n1 t2 - | mul_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - - -Definition mulhs (e1: expr) (e2: expr) := - if Archi.ptr64 then - Eop Olowlong - (Eop (Oshrlimm (Int.repr 32)) - (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: - Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) - ::: Enil) - else - Eop Omulhs (e1 ::: e2 ::: Enil). - -Definition mulhu (e1: expr) (e2: expr) := - if Archi.ptr64 then - Eop Olowlong - (Eop (Oshrluimm (Int.repr 32)) - (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: - Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) - ::: Enil) - else - Eop Omulhu (e1 ::: e2 ::: Enil). - -(** ** Bitwise and, or, xor *) - -(** Original definition: -<< -Nondetfunction andimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.mone then e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil - | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) - | Eop Onot (t2:::Enil) => Eop (Oandnimm n1) (t2:::Enil) - | _ => Eop (Oandimm n1) (e2:::Enil) - end. ->> -*) - -Inductive andimm_cases: forall (e2: expr), Type := - | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) - | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) - | andimm_case3: forall t2, andimm_cases (Eop Onot (t2:::Enil)) - | andimm_default: forall (e2: expr), andimm_cases e2. - -Definition andimm_match (e2: expr) := - match e2 as zz1 return andimm_cases zz1 with - | Eop (Ointconst n2) Enil => andimm_case1 n2 - | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 - | Eop Onot (t2:::Enil) => andimm_case3 t2 - | e2 => andimm_default e2 - end. - -Definition andimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.mone then e2 else match andimm_match e2 with - | andimm_case1 n2 => (* Eop (Ointconst n2) Enil *) - Eop (Ointconst (Int.and n1 n2)) Enil - | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) - Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) - | andimm_case3 t2 => (* Eop Onot (t2:::Enil) *) - Eop (Oandnimm n1) (t2:::Enil) - | andimm_default e2 => - Eop (Oandimm n1) (e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction and (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 - | t1, Eop (Ointconst n2) Enil => andimm n2 t1 - | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) - | t1, (Eop Onot (t2:::Enil)) => Eop Oandn (t2:::t1:::Enil) - | _, _ => Eop Oand (e1:::e2:::Enil) - end. ->> -*) - -Inductive and_cases: forall (e1: expr) (e2: expr), Type := - | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) - | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) - | and_case3: forall t1 t2, and_cases ((Eop Onot (t1:::Enil))) (t2) - | and_case4: forall t1 t2, and_cases (t1) ((Eop Onot (t2:::Enil))) - | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. - -Definition and_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 - | (Eop Onot (t1:::Enil)), t2 => and_case3 t1 t2 - | t1, (Eop Onot (t2:::Enil)) => and_case4 t1 t2 - | e1, e2 => and_default e1 e2 - end. - -Definition and (e1: expr) (e2: expr) := - match and_match e1 e2 with - | and_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - andimm n1 t2 - | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - andimm n2 t1 - | and_case3 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) - Eop Oandn (t1:::t2:::Enil) - | and_case4 t1 t2 => (* t1, (Eop Onot (t2:::Enil)) *) - Eop Oandn (t2:::t1:::Enil) - | and_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction orimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 - else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil - | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) - | Eop Onot (t2:::Enil) => Eop (Oornimm n1) (t2:::Enil) - | _ => Eop (Oorimm n1) (e2:::Enil) - end. ->> -*) - -Inductive orimm_cases: forall (e2: expr), Type := - | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) - | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) - | orimm_case3: forall t2, orimm_cases (Eop Onot (t2:::Enil)) - | orimm_default: forall (e2: expr), orimm_cases e2. - -Definition orimm_match (e2: expr) := - match e2 as zz1 return orimm_cases zz1 with - | Eop (Ointconst n2) Enil => orimm_case1 n2 - | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 - | Eop Onot (t2:::Enil) => orimm_case3 t2 - | e2 => orimm_default e2 - end. - -Definition orimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil else match orimm_match e2 with - | orimm_case1 n2 => (* Eop (Ointconst n2) Enil *) - Eop (Ointconst (Int.or n1 n2)) Enil - | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) - Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) - | orimm_case3 t2 => (* Eop Onot (t2:::Enil) *) - Eop (Oornimm n1) (t2:::Enil) - | orimm_default e2 => - Eop (Oorimm n1) (e2:::Enil) - end. - - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -(** Original definition: -<< -Nondetfunction or (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 - | t1, Eop (Ointconst n2) Enil => orimm n2 t1 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - 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 Oor (e1:::e2:::Enil) - end. ->> -*) - -Inductive or_cases: forall (e1: expr) (e2: expr), Type := - | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) - | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) - | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) - | or_case4: forall n2 t2 n1 t1, or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) - | or_case5: forall t1 t2, or_cases ((Eop Onot (t1:::Enil))) (t2) - | or_case6: forall t1 t2, or_cases (t1) ((Eop Onot (t2:::Enil))) - | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => or_case3 n1 t1 n2 t2 - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => or_case4 n2 t2 n1 t1 - | (Eop Onot (t1:::Enil)), t2 => or_case5 t1 t2 - | t1, (Eop Onot (t2:::Enil)) => or_case6 t1 t2 - | e1, e2 => or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - orimm n1 t2 - | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - orimm n2 t1 - | or_case3 n1 t1 n2 t2 => (* Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) *) - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) - | or_case4 n2 t2 n1 t1 => (* Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) *) - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 then Eop (Ororimm n2) (t1:::Enil) else Eop Oor (e1:::e2:::Enil) - | or_case5 t1 t2 => (* (Eop Onot (t1:::Enil)), t2 *) - Eop Oorn (t1:::t2:::Enil) - | or_case6 t1 t2 => (* t1, (Eop Onot (t2:::Enil)) *) - Eop Oorn (t2:::t1:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction xorimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 else - match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil - | Eop (Oxorimm n2) (t2:::Enil) => - let n := Int.xor n1 n2 in - if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) - | _ => Eop (Oxorimm n1) (e2:::Enil) - end. ->> -*) - -Inductive xorimm_cases: forall (e2: expr), Type := - | xorimm_case1: forall n2, xorimm_cases (Eop (Ointconst n2) Enil) - | xorimm_case2: forall n2 t2, xorimm_cases (Eop (Oxorimm n2) (t2:::Enil)) - | xorimm_default: forall (e2: expr), xorimm_cases e2. - -Definition xorimm_match (e2: expr) := - match e2 as zz1 return xorimm_cases zz1 with - | Eop (Ointconst n2) Enil => xorimm_case1 n2 - | Eop (Oxorimm n2) (t2:::Enil) => xorimm_case2 n2 t2 - | e2 => xorimm_default e2 - end. - -Definition xorimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 else match xorimm_match e2 with - | xorimm_case1 n2 => (* Eop (Ointconst n2) Enil *) - Eop (Ointconst (Int.xor n1 n2)) Enil - | xorimm_case2 n2 t2 => (* Eop (Oxorimm n2) (t2:::Enil) *) - let n := Int.xor n1 n2 in if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) - | xorimm_default e2 => - Eop (Oxorimm n1) (e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction xor (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 - | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 - | _, _ => Eop Oxor (e1:::e2:::Enil) - end. ->> -*) - -Inductive xor_cases: forall (e1: expr) (e2: expr), Type := - | xor_case1: forall n1 t2, xor_cases (Eop (Ointconst n1) Enil) (t2) - | xor_case2: forall t1 n2, xor_cases (t1) (Eop (Ointconst n2) Enil) - | xor_default: forall (e1: expr) (e2: expr), xor_cases e1 e2. - -Definition xor_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return xor_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => xor_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => xor_case2 t1 n2 - | e1, e2 => xor_default e1 e2 - end. - -Definition xor (e1: expr) (e2: expr) := - match xor_match e1 e2 with - | xor_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - xorimm n1 t2 - | xor_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - xorimm n2 t1 - | xor_default e1 e2 => - Eop Oxor (e1:::e2:::Enil) - end. - - -(** ** Integer logical negation *) - -(** Original definition: -<< -Nondetfunction notint (e: expr) := - match e with - | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) - | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) - | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) - | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) - | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) - | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) - | _ => Eop Onot (e:::Enil) - end. ->> -*) - -Inductive notint_cases: forall (e: expr), Type := - | notint_case1: forall e1 e2, notint_cases (Eop Oand (e1:::e2:::Enil)) - | notint_case2: forall n e1, notint_cases (Eop (Oandimm n) (e1:::Enil)) - | notint_case3: forall e1 e2, notint_cases (Eop Oor (e1:::e2:::Enil)) - | notint_case4: forall n e1, notint_cases (Eop (Oorimm n) (e1:::Enil)) - | notint_case5: forall e1 e2, notint_cases (Eop Oxor (e1:::e2:::Enil)) - | notint_case6: forall n e1, notint_cases (Eop (Oxorimm n) (e1:::Enil)) - | notint_default: forall (e: expr), notint_cases e. - -Definition notint_match (e: expr) := - match e as zz1 return notint_cases zz1 with - | Eop Oand (e1:::e2:::Enil) => notint_case1 e1 e2 - | Eop (Oandimm n) (e1:::Enil) => notint_case2 n e1 - | Eop Oor (e1:::e2:::Enil) => notint_case3 e1 e2 - | Eop (Oorimm n) (e1:::Enil) => notint_case4 n e1 - | Eop Oxor (e1:::e2:::Enil) => notint_case5 e1 e2 - | Eop (Oxorimm n) (e1:::Enil) => notint_case6 n e1 - | e => notint_default e - end. - -Definition notint (e: expr) := - match notint_match e with - | notint_case1 e1 e2 => (* Eop Oand (e1:::e2:::Enil) *) - Eop Onand (e1:::e2:::Enil) - | notint_case2 n e1 => (* Eop (Oandimm n) (e1:::Enil) *) - Eop (Onandimm n) (e1:::Enil) - | notint_case3 e1 e2 => (* Eop Oor (e1:::e2:::Enil) *) - Eop Onor (e1:::e2:::Enil) - | notint_case4 n e1 => (* Eop (Oorimm n) (e1:::Enil) *) - Eop (Onorimm n) (e1:::Enil) - | notint_case5 e1 e2 => (* Eop Oxor (e1:::e2:::Enil) *) - Eop Onxor (e1:::e2:::Enil) - | notint_case6 n e1 => (* Eop (Oxorimm n) (e1:::Enil) *) - Eop (Onxorimm n) (e1:::Enil) - | notint_default e => - Eop Onot (e:::Enil) - end. - - -(** ** Integer division and modulus *) - -Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). -Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). -Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). -Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). - -Definition shrximm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). - -(* Alternate definition, not convenient for strength reduction during constant propagation *) -(* -(* n2 will be less than 31. *) - -Definition shrximm_inner (e1: expr) (n2: int) := - Eop (Oshruimm (Int.sub Int.iwordsize n2)) - ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) - (e1 ::: Enil)) - ::: Enil). - -Definition shrximm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then e1 - else Eop (Oshrimm n2) - ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) - ::: Enil). -*) - -(** ** General shifts *) - -(** Original definition: -<< -Nondetfunction shl (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shlimm e1 n2 - | _ => Eop Oshl (e1:::e2:::Enil) - end. ->> -*) - -Inductive shl_cases: forall (e2: expr), Type := - | shl_case1: forall n2, shl_cases (Eop (Ointconst n2) Enil) - | shl_default: forall (e2: expr), shl_cases e2. - -Definition shl_match (e2: expr) := - match e2 as zz1 return shl_cases zz1 with - | Eop (Ointconst n2) Enil => shl_case1 n2 - | e2 => shl_default e2 - end. - -Definition shl (e1: expr) (e2: expr) := - match shl_match e2 with - | shl_case1 n2 => (* Eop (Ointconst n2) Enil *) - shlimm e1 n2 - | shl_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shr (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shrimm e1 n2 - | _ => Eop Oshr (e1:::e2:::Enil) - end. ->> -*) - -Inductive shr_cases: forall (e2: expr), Type := - | shr_case1: forall n2, shr_cases (Eop (Ointconst n2) Enil) - | shr_default: forall (e2: expr), shr_cases e2. - -Definition shr_match (e2: expr) := - match e2 as zz1 return shr_cases zz1 with - | Eop (Ointconst n2) Enil => shr_case1 n2 - | e2 => shr_default e2 - end. - -Definition shr (e1: expr) (e2: expr) := - match shr_match e2 with - | shr_case1 n2 => (* Eop (Ointconst n2) Enil *) - shrimm e1 n2 - | shr_default e2 => - Eop Oshr (e1:::e2:::Enil) - end. - - -(** Original definition: -<< -Nondetfunction shru (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shruimm e1 n2 - | _ => Eop Oshru (e1:::e2:::Enil) - end. ->> -*) - -Inductive shru_cases: forall (e2: expr), Type := - | shru_case1: forall n2, shru_cases (Eop (Ointconst n2) Enil) - | shru_default: forall (e2: expr), shru_cases e2. - -Definition shru_match (e2: expr) := - match e2 as zz1 return shru_cases zz1 with - | Eop (Ointconst n2) Enil => shru_case1 n2 - | e2 => shru_default e2 - end. - -Definition shru (e1: expr) (e2: expr) := - match shru_match e2 with - | shru_case1 n2 => (* Eop (Ointconst n2) Enil *) - shruimm e1 n2 - | shru_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - - -(** ** Floating-point arithmetic *) - -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). - -Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). -Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). -Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). -Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). -Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). - -(** ** Comparisons *) - -(** Original definition: -<< -Nondetfunction compimm (default: comparison -> int -> condition) - (sem: comparison -> int -> int -> bool) - (c: comparison) (e1: expr) (n2: int) := - match c, e1 with - | c, Eop (Ointconst n1) Enil => - Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil - | Ceq, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp (negate_condition c)) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp c) el - else - Eop (Ointconst Int.zero) Enil - | Cne, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp c) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp (negate_condition c)) el - else - Eop (Ointconst Int.one) Enil - | _, _ => - Eop (Ocmp (default c n2)) (e1 ::: Enil) - end. ->> -*) - -Inductive compimm_cases: forall (c: comparison) (e1: expr) , Type := - | compimm_case1: forall c n1, compimm_cases (c) (Eop (Ointconst n1) Enil) - | compimm_case2: forall c el, compimm_cases (Ceq) (Eop (Ocmp c) el) - | compimm_case3: forall c el, compimm_cases (Cne) (Eop (Ocmp c) el) - | compimm_default: forall (c: comparison) (e1: expr) , compimm_cases c e1. - -Definition compimm_match (c: comparison) (e1: expr) := - match c as zz1, e1 as zz2 return compimm_cases zz1 zz2 with - | c, Eop (Ointconst n1) Enil => compimm_case1 c n1 - | Ceq, Eop (Ocmp c) el => compimm_case2 c el - | Cne, Eop (Ocmp c) el => compimm_case3 c el - | c, e1 => compimm_default c e1 - end. - -Definition compimm (default: comparison -> int -> condition) (sem: comparison -> int -> int -> bool) (c: comparison) (e1: expr) (n2: int) := - match compimm_match c e1 with - | compimm_case1 c n1 => (* c, Eop (Ointconst n1) Enil *) - Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil - | compimm_case2 c el => (* Ceq, Eop (Ocmp c) el *) - if Int.eq_dec n2 Int.zero then Eop (Ocmp (negate_condition c)) el else if Int.eq_dec n2 Int.one then Eop (Ocmp c) el else Eop (Ointconst Int.zero) Enil - | compimm_case3 c el => (* Cne, Eop (Ocmp c) el *) - if Int.eq_dec n2 Int.zero then Eop (Ocmp c) el else if Int.eq_dec n2 Int.one then Eop (Ocmp (negate_condition c)) el else Eop (Ointconst Int.one) Enil - | compimm_default c e1 => - Eop (Ocmp (default c n2)) (e1 ::: Enil) - end. - - -(** Original definition: -<< -Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompimm Int.cmp c t1 n2 - | _, _ => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. ->> -*) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Type := - | comp_case1: forall n1 t2, comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: forall t1 n2, comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: forall (e1: expr) (e2: expr), comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return comp_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => comp_case2 t1 n2 - | e1, e2 => comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 - | comp_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - compimm Ccompimm Int.cmp c t1 n2 - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - - -(** Original definition: -<< -Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompuimm Int.cmpu c t1 n2 - | _, _ => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. ->> -*) - -Inductive compu_cases: forall (e1: expr) (e2: expr), Type := - | compu_case1: forall n1 t2, compu_cases (Eop (Ointconst n1) Enil) (t2) - | compu_case2: forall t1 n2, compu_cases (t1) (Eop (Ointconst n2) Enil) - | compu_default: forall (e1: expr) (e2: expr), compu_cases e1 e2. - -Definition compu_match (e1: expr) (e2: expr) := - match e1 as zz1, e2 as zz2 return compu_cases zz1 zz2 with - | Eop (Ointconst n1) Enil, t2 => compu_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => compu_case2 t1 n2 - | e1, e2 => compu_default e1 e2 - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match compu_match e1 e2 with - | compu_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) - compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 - | compu_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) - compimm Ccompuimm Int.cmpu c t1 n2 - | compu_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -Definition compfs (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). - -(** ** Integer conversions *) - -Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. - -(** Original definition: -<< -Nondetfunction cast8signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil - | _ => Eop Ocast8signed (e ::: Enil) - end. ->> -*) - -Inductive cast8signed_cases: forall (e: expr), Type := - | cast8signed_case1: forall n, cast8signed_cases (Eop (Ointconst n) Enil) - | cast8signed_default: forall (e: expr), cast8signed_cases e. - -Definition cast8signed_match (e: expr) := - match e as zz1 return cast8signed_cases zz1 with - | Eop (Ointconst n) Enil => cast8signed_case1 n - | e => cast8signed_default e - end. - -Definition cast8signed (e: expr) := - match cast8signed_match e with - | cast8signed_case1 n => (* Eop (Ointconst n) Enil *) - Eop (Ointconst (Int.sign_ext 8 n)) Enil - | cast8signed_default e => - Eop Ocast8signed (e ::: Enil) - end. - - -Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. - -(** Original definition: -<< -Nondetfunction cast16signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil - | _ => Eop Ocast16signed (e ::: Enil) - end. ->> -*) - -Inductive cast16signed_cases: forall (e: expr), Type := - | cast16signed_case1: forall n, cast16signed_cases (Eop (Ointconst n) Enil) - | cast16signed_default: forall (e: expr), cast16signed_cases e. - -Definition cast16signed_match (e: expr) := - match e as zz1 return cast16signed_cases zz1 with - | Eop (Ointconst n) Enil => cast16signed_case1 n - | e => cast16signed_default e - end. - -Definition cast16signed (e: expr) := - match cast16signed_match e with - | cast16signed_case1 n => (* Eop (Ointconst n) Enil *) - Eop (Ointconst (Int.sign_ext 16 n)) Enil - | cast16signed_default e => - Eop Ocast16signed (e ::: Enil) - end. - - -(** ** Floating-point conversions *) - -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). -Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). - -(** Original definition: -<< -Nondetfunction floatofintu (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil - | _ => Eop Ofloatofintu (e ::: Enil) - end. ->> -*) - -Inductive floatofintu_cases: forall (e: expr), Type := - | floatofintu_case1: forall n, floatofintu_cases (Eop (Ointconst n) Enil) - | floatofintu_default: forall (e: expr), floatofintu_cases e. - -Definition floatofintu_match (e: expr) := - match e as zz1 return floatofintu_cases zz1 with - | Eop (Ointconst n) Enil => floatofintu_case1 n - | e => floatofintu_default e - end. - -Definition floatofintu (e: expr) := - match floatofintu_match e with - | floatofintu_case1 n => (* Eop (Ointconst n) Enil *) - Eop (Ofloatconst (Float.of_intu n)) Enil - | floatofintu_default e => - Eop Ofloatofintu (e ::: Enil) - end. - - -(** Original definition: -<< -Nondetfunction floatofint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil - | _ => Eop Ofloatofint (e ::: Enil) - end. ->> -*) - -Inductive floatofint_cases: forall (e: expr), Type := - | floatofint_case1: forall n, floatofint_cases (Eop (Ointconst n) Enil) - | floatofint_default: forall (e: expr), floatofint_cases e. - -Definition floatofint_match (e: expr) := - match e as zz1 return floatofint_cases zz1 with - | Eop (Ointconst n) Enil => floatofint_case1 n - | e => floatofint_default e - end. - -Definition floatofint (e: expr) := - match floatofint_match e with - | floatofint_case1 n => (* Eop (Ointconst n) Enil *) - Eop (Ofloatconst (Float.of_int n)) Enil - | floatofint_default e => - Eop Ofloatofint (e ::: Enil) - end. - - -Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). -Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). - -Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). -Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). - -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). - -(** ** Recognition of addressing modes for load and store operations *) - -(** Original definition: -<< -Nondetfunction addressing (chunk: memory_chunk) (e: expr) := - match e with - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code 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) - | _ => (Aindexed Ptrofs.zero, e:::Enil) - end. ->> -*) - -Inductive addressing_cases: forall (e: expr), Type := - | addressing_case1: forall n, addressing_cases (Eop (Oaddrstack n) Enil) - | addressing_case2: forall id ofs, addressing_cases (Eop (Oaddrsymbol id ofs) Enil) - | addressing_case3: forall n e1, addressing_cases (Eop (Oaddimm n) (e1:::Enil)) - | addressing_case4: forall n e1, addressing_cases (Eop (Oaddlimm n) (e1:::Enil)) - | addressing_default: forall (e: expr), addressing_cases e. - -Definition addressing_match (e: expr) := - match e as zz1 return addressing_cases zz1 with - | Eop (Oaddrstack n) Enil => addressing_case1 n - | Eop (Oaddrsymbol id ofs) Enil => addressing_case2 id ofs - | Eop (Oaddimm n) (e1:::Enil) => addressing_case3 n e1 - | Eop (Oaddlimm n) (e1:::Enil) => addressing_case4 n e1 - | e => addressing_default e - end. - -Definition addressing (chunk: memory_chunk) (e: expr) := - match addressing_match e with - | addressing_case1 n => (* Eop (Oaddrstack n) Enil *) - (Ainstack n, Enil) - | addressing_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) - if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) - | addressing_case3 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) - (Aindexed (Ptrofs.of_int n), e1:::Enil) - | addressing_case4 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) - (Aindexed (Ptrofs.of_int64 n), e1:::Enil) - | addressing_default e => - (Aindexed Ptrofs.zero, e:::Enil) - end. - - -(** ** Arguments of builtins *) - -(** Original definition: -<< -Nondetfunction builtin_arg (e: expr) := - match e with - | Eop (Ointconst n) Enil => BA_int n - | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs - | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs - | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - BA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) - | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs - | Eop (Oaddimm n) (e1:::Enil) => - if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) - | Eop (Oaddlimm n) (e1:::Enil) => - if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e - | _ => BA e - end. ->> -*) - -Inductive builtin_arg_cases: forall (e: expr), Type := - | builtin_arg_case1: forall n, builtin_arg_cases (Eop (Ointconst n) Enil) - | builtin_arg_case2: forall id ofs, builtin_arg_cases (Eop (Oaddrsymbol id ofs) Enil) - | builtin_arg_case3: forall ofs, builtin_arg_cases (Eop (Oaddrstack ofs) Enil) - | builtin_arg_case4: forall h l, builtin_arg_cases (Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil)) - | builtin_arg_case5: forall h l, builtin_arg_cases (Eop Omakelong (h ::: l ::: Enil)) - | builtin_arg_case6: forall chunk ofs, builtin_arg_cases (Eload chunk (Ainstack ofs) Enil) - | builtin_arg_case7: forall n e1, builtin_arg_cases (Eop (Oaddimm n) (e1:::Enil)) - | builtin_arg_case8: forall n e1, builtin_arg_cases (Eop (Oaddlimm n) (e1:::Enil)) - | builtin_arg_default: forall (e: expr), builtin_arg_cases e. - -Definition builtin_arg_match (e: expr) := - match e as zz1 return builtin_arg_cases zz1 with - | Eop (Ointconst n) Enil => builtin_arg_case1 n - | Eop (Oaddrsymbol id ofs) Enil => builtin_arg_case2 id ofs - | Eop (Oaddrstack ofs) Enil => builtin_arg_case3 ofs - | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => builtin_arg_case4 h l - | Eop Omakelong (h ::: l ::: Enil) => builtin_arg_case5 h l - | Eload chunk (Ainstack ofs) Enil => builtin_arg_case6 chunk ofs - | Eop (Oaddimm n) (e1:::Enil) => builtin_arg_case7 n e1 - | Eop (Oaddlimm n) (e1:::Enil) => builtin_arg_case8 n e1 - | e => builtin_arg_default e - end. - -Definition builtin_arg (e: expr) := - match builtin_arg_match e with - | builtin_arg_case1 n => (* Eop (Ointconst n) Enil *) - BA_int n - | builtin_arg_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) - BA_addrglobal id ofs - | builtin_arg_case3 ofs => (* Eop (Oaddrstack ofs) Enil *) - BA_addrstack ofs - | builtin_arg_case4 h l => (* Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) *) - BA_long (Int64.ofwords h l) - | builtin_arg_case5 h l => (* Eop Omakelong (h ::: l ::: Enil) *) - BA_splitlong (BA h) (BA l) - | builtin_arg_case6 chunk ofs => (* Eload chunk (Ainstack ofs) Enil *) - BA_loadstack chunk ofs - | builtin_arg_case7 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) - if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) - | builtin_arg_case8 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) - if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e - | builtin_arg_default e => - BA e - end. - -- cgit From f321f75979d18ab99f226b2c5d6bbb59bffb5cac Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 19 Mar 2019 15:50:22 +0100 Subject: Pseudo instruction for 32 bits division, no code generation yet --- mppa_k1c/Asm.v | 5 ++++ mppa_k1c/Asmblock.v | 17 +++++++++++--- mppa_k1c/Asmblockdeps.v | 45 ++++++++++++++++++++++++++++++++++++ mppa_k1c/Asmblockgen.v | 4 ++-- mppa_k1c/Asmblockgenproof.v | 3 ++- mppa_k1c/PostpassScheduling.v | 25 ++++++++++---------- mppa_k1c/PostpassSchedulingOracle.ml | 3 ++- mppa_k1c/TargetPrinter.ml | 4 ++++ 8 files changed, 87 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 8486e25d..029ac995 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -50,6 +50,9 @@ Inductive instruction : Type := | Psemi (**r semi colon separating bundles *) | Pnop (**r instruction that does nothing *) + | Pdiv (**r 32 bits integer division *) + | Pdivu (**r 32 bits integer division *) + (** builtins *) | Pclzll (rd rs: ireg) | Pstsud (rd rs1 rs2: ireg) @@ -209,6 +212,8 @@ Inductive instruction : Type := Definition control_to_instruction (c: control) := match c with | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res + | PExpand (Asmblock.Pdiv) => Pdiv + | PExpand (Asmblock.Pdivu) => Pdivu | PCtlFlow Asmblock.Pret => Pret | PCtlFlow (Asmblock.Pcall l) => Pcall l | PCtlFlow (Asmblock.Picall r) => Picall r diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 4f9fc34d..03c7e6d5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -179,6 +179,8 @@ Inductive ex_instruction : Type := | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) + | Pdiv (**r 32 bits integer division, call to __divdi3 *) + | Pdivu (**r 32 bits integer division, call to __udivdi3 *) . (** FIXME: comment not up to date ! @@ -523,9 +525,8 @@ Proof. assert (b :: body = nil). eapply H; eauto. discriminate. - destruct body; destruct exit. all: simpl; auto; try constructor. - + exploreInst. + + exploreInst; try discriminate. simpl. contradiction. - discriminate. + intros. discriminate. Qed. @@ -1437,10 +1438,20 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) | (None, _) => Stuck end - (** Pseudo-instructions *) | Pbuiltin ef args res => Stuck (**r treated specially below *) + | Pdiv => + match Val.divs (rs GPR0) (rs GPR1) with + | Some v => Next (rs # GPR0 <- v # RA <- (rs RA)) m + | None => Stuck + end + + | Pdivu => + match Val.divu (rs GPR0) (rs GPR1) with + | Some v => Next (rs # GPR0 <- v # RA <- (rs RA)) m + | None => Stuck + end end | None => Next rs m end. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a2d75b27..7e9fb8f1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -38,6 +38,8 @@ Inductive control_op := | Oj_l (l: label) | Ocb (bt: btest) (l: label) | Ocbu (bt: btest) (l: label) + | Odiv + | Odivu | OError | OIncremPC (sz: Z) . @@ -185,6 +187,16 @@ Definition control_eval (o: control_op) (l: list value) := | (Some c, Long) => eval_branch_deps fn l vpc (Val_cmplu_bool c v (Vlong (Int64.repr 0))) | (None, _) => None end + | Odiv, [Val v1; Val v2] => + match Val.divs v1 v2 with + | Some v => Some (Val v) + | None => None + end + | Odivu, [Val v1; Val v2] => + match Val.divu v1 v2 with + | Some v => Some (Val v) + | None => None + end | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) | OError, _ => None | _, _ => None @@ -323,6 +335,8 @@ Definition control_op_eq (c1 c2: control_op): ?? bool := | Oj_l l1, Oj_l l2 => phys_eq l1 l2 | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) + | Odiv, Odiv => RET true + | Odivu, Odivu => RET true | OIncremPC sz1, OIncremPC sz2 => RET (Z.eqb sz1 sz2) | OError, OError => RET true | _, _ => RET false @@ -504,6 +518,8 @@ Definition trans_control (ctl: control) : macro := | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] + | Pdiv => [(#GPR0, Op (Control Odiv) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] + | Pdivu => [(#GPR0, Op (Control Odivu) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. @@ -801,6 +817,22 @@ Proof. intros. destruct ex. - simpl in *. inv H1. destruct c; destruct i; try discriminate. all: try (inv H0; eexists; split; try split; [ simpl control_eval; pose (H3 PC); simpl in e; rewrite e; reflexivity | Simpl | intros rr; destruct rr; Simpl]). + (* Pdiv *) + + destruct (Val.divs _ _) eqn:DIVS; try discriminate. inv H0. unfold nextblock in DIVS. repeat (rewrite Pregmap.gso in DIVS; try discriminate). + eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e; clear e. simpl. + Simpl. pose (H3 GPR0); rewrite e; clear e. pose (H3 GPR1); rewrite e; clear e. rewrite DIVS. + Simpl. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. + (* Pdivu *) + + destruct (Val.divu _ _) eqn:DIVU; try discriminate. inv H0. unfold nextblock in DIVU. repeat (rewrite Pregmap.gso in DIVU; try discriminate). + eexists; split; try split. + * simpl control_eval. pose (H3 PC); simpl in e; rewrite e; clear e. simpl. + Simpl. pose (H3 GPR0); rewrite e; clear e. pose (H3 GPR1); rewrite e; clear e. rewrite DIVU. + Simpl. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. (* Pj_l *) + unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. eexists; split; try split. @@ -992,6 +1024,12 @@ Lemma exec_exit_none: Proof. intros. inv H0. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try reflexivity; try discriminate. +(* Pdiv *) + - simpl in *. pose (H3 GPR0); rewrite e in H1; clear e. pose (H3 GPR1); rewrite e in H1; clear e. + destruct (Val.divs _ _); try discriminate; auto. +(* Pdivu *) + - simpl in *. pose (H3 GPR0); rewrite e in H1; clear e. pose (H3 GPR1); rewrite e in H1; clear e. + destruct (Val.divu _ _); try discriminate; auto. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. unfold goto_label_deps in H1. unfold goto_label. @@ -1103,6 +1141,11 @@ Lemma forward_simu_exit_stuck: Proof. intros. inv H1. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). +(* Pdiv *) + - simpl in *. pose (H3 GPR0); simpl in e; rewrite e; clear e. pose (H3 GPR1); simpl in e; rewrite e; clear e. + destruct (Val.divs _ _); try discriminate; auto. + - simpl in *. pose (H3 GPR0); simpl in e; rewrite e; clear e. pose (H3 GPR1); simpl in e; rewrite e; clear e. + destruct (Val.divu _ _); try discriminate; auto. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold goto_label in H0. destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. @@ -1421,6 +1464,8 @@ Definition string_of_control (op: control_op) : pstring := | Oj_l _ => "Oj_l" | Ocb _ _ => "Ocb" | Ocbu _ _ => "Ocbu" + | Odiv => "Odiv" + | Odivu => "Odivu" | OError => "OError" | OIncremPC _ => "OIncremPC" end. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 4b168eec..c54394eb 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -960,7 +960,7 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr | _ => {| header := hd; body := c; exit := None |} :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil end - | Some (PCtlFlow i) => {| header := hd; body := (c ++ extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil + | Some ex => {| header := hd; body := (c ++ extract_basic ctl); exit := Some ex |} :: nil end . Next Obligation. @@ -970,7 +970,7 @@ Next Obligation. Qed. Next Obligation. apply wf_bblock_refl. constructor. right. discriminate. - discriminate. + unfold builtin_alone. intros. pose (H ef args res). rewrite H0 in n. contradiction. Qed. Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ddc96f6c..ea4d1918 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -935,7 +935,8 @@ Proof. intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. destruct (extract_ctl tex) eqn:ECTL. - destruct c. - + destruct i. assert False. eapply Hnobuiltin. eauto. destruct H. + + 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. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index b5d55ad3..6700e684 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -118,7 +118,7 @@ Proof. destruct hdb. - destruct exb. + destruct c. - * destruct i. monadInv H. + * destruct i; monadInv H; split; auto. * monadInv H. split; auto. + monadInv H. split; auto. - monadInv H. @@ -131,7 +131,8 @@ Proof. destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). - destruct c. - + destruct i; try (monadInv EQ2). + + destruct i; monadInv EQ2; + unfold size; simpl; rewrite app_length; rewrite Nat.add_0_r; rewrite <- Nat2Z.inj_add; rewrite Nat.add_assoc; reflexivity. + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. Qed. @@ -144,7 +145,7 @@ Proof. unfold concat2 in H. simpl in H. monadInv H. destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. - destruct c. - + destruct i; discriminate. + + destruct i; try discriminate; congruence. + congruence. - congruence. Qed. @@ -259,7 +260,7 @@ Proof. destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. - destruct c. - + destruct i. discriminate. + + destruct i; try discriminate; inv EQ2; unfold stick_header; simpl; reflexivity. + inv EQ2. unfold stick_header; simpl. reflexivity. - inv EQ2. unfold stick_header; simpl. reflexivity. Qed. @@ -393,9 +394,9 @@ Definition verified_schedule (bb : bblock) : res (list bblock) := Lemma verified_schedule_size: forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (apply verified_schedule_nob_size; auto; fail). - destruct i. inv H. simpl. omega. + inv H. simpl. omega. Qed. Lemma verified_schedule_no_header_in_middle: @@ -403,9 +404,9 @@ Lemma verified_schedule_no_header_in_middle: verified_schedule bb = OK lbb -> Forall (fun b => header b = nil) (tail lbb). Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (eapply verified_schedule_nob_no_header_in_middle; eauto; fail). - destruct i. inv H. simpl. auto. + inv H. simpl. auto. Qed. Lemma verified_schedule_header: @@ -414,9 +415,9 @@ Lemma verified_schedule_header: header bb = header tbb /\ Forall (fun b => header b = nil) lbb. Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (eapply verified_schedule_nob_header; eauto; fail). - destruct i. inv H. split; simpl; auto. + inv H. split; simpl; auto. Qed. @@ -443,9 +444,9 @@ Theorem verified_schedule_correct: concat_all lbb = OK tbb /\ bblock_equiv ge f bb tbb. Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (eapply verified_schedule_nob_correct; eauto; fail). - destruct i. inv H. eexists. split; simpl; auto. constructor; auto. + inv H. eexists. split; simpl; auto. constructor; auto. Qed. Lemma verified_schedule_builtin_idem: diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ce2fb2ae..ac257af3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -206,6 +206,7 @@ let basic_rec i = | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false} let expand_rec = function + | Pdiv | Pdivu -> { inst = "Pdiv"; write_locs = [Reg (IR GPR0)]; read_locs = [Reg (IR GPR0); Reg (IR GPR1)]; imm = None; is_control = true } | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function @@ -477,7 +478,7 @@ let ab_inst_to_real = function | "Psd" | "Psd_a" | "Pfsd" -> Sd | "Pcb" | "Pcbu" -> Cb - | "Pcall" -> Call + | "Pcall" | "Pdiv" | "Pdivu" -> Call | "Picall" -> Icall | "Pgoto" | "Pj_l" -> Goto | "Pigoto" -> Igoto diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 511537ce..d79a2be8 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -258,6 +258,10 @@ module Target (*: TARGET*) = fprintf oc " goto %a\n" symbol s | Pigoto(rs) -> fprintf oc " igoto %a\n" ireg rs + | Pdiv -> + fprintf oc " call __divdi3\n" + | Pdivu -> + fprintf oc " call __udivdi3\n" | Pj_l(s) -> fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> -- cgit From 3125e65d78c9f06514574650648b3d5b5adaacbd Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 19 Mar 2019 17:36:36 +0100 Subject: remove a FAILWITH that forbids some debugging information to be printed --- mppa_k1c/abstractbb/ImpDep.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 0cce7ce3..9051f6ad 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -386,7 +386,7 @@ Variable print_error_end: hdeps -> hdeps -> ?? unit. Variable print_error: pstring -> ?? unit. Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := - DO r <~ (TRY + 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 ;; @@ -395,7 +395,7 @@ Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := print_error_end d1 d2 ;; RET false ) - CATCH_FAIL s, _ => + CATCH_FAIL s, _ => print_error s;; RET false ENSURE (fun b => b=true -> forall ge, bblock_equiv ge p1 p2));; @@ -633,7 +633,7 @@ Definition print_witness ext exl cr msg := println(r);; println("=> encoded on " +; msg +; " graph as: ");; print_raw_hlist pl - | _ => FAILWITH "No witness info" + | _ => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" end. -- cgit From 6ae5c96b2905220cc31535fb93a2e853249adae7 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 19 Mar 2019 17:39:26 +0100 Subject: fix missing case in Asmblockdeps.arith_op_eq --- mppa_k1c/Asmblockdeps.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 5a138d00..f28e660c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -286,6 +286,7 @@ Definition arith_op_eq (o1 o2: arith_op): ?? bool := | OArithRRR n1, OArithRRR n2 => phys_eq n1 n2 | OArithRRI32 n1 i1, OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | OArithRRI64 n1 i1, OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) + | OArithARRR n1, OArithARRR n2 => phys_eq n1 n2 | _, _ => RET false end. @@ -381,13 +382,12 @@ Qed. (* 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. -- cgit From d1dfa934a33da18eab0424012cf4dd2b602c21a5 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 19 Mar 2019 18:05:49 +0100 Subject: improve robustness of Asmblockdeps.arith_op_eq. --- mppa_k1c/Asmblockdeps.v | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index f28e660c..e05f92a7 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -276,18 +276,31 @@ Definition iandb (ib1 ib2: ?? bool): ?? bool := RET (andb b1 b2). Definition arith_op_eq (o1 o2: arith_op): ?? bool := - match o1, o2 with - | OArithR n1, OArithR n2 => struct_eq n1 n2 - | OArithRR n1, OArithRR n2 => phys_eq n1 n2 - | OArithRI32 n1 i1, OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithRI64 n1 i1, OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithRF32 n1 i1, OArithRF32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithRF64 n1 i1, OArithRF64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithRRR n1, OArithRRR n2 => phys_eq n1 n2 - | OArithRRI32 n1 i1, OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithRRI64 n1 i1, OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) - | OArithARRR n1, OArithARRR n2 => phys_eq n1 n2 - | _, _ => RET false + match o1 with + | OArithR n1 => + match o2 with OArithR n2 => struct_eq n1 n2 | _ => RET false end + | OArithRR n1 => + match o2 with OArithRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithRI32 n1 i1 => + match o2 with OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRI64 n1 i1 => + match o2 with OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRF32 n1 i1 => + match o2 with OArithRF32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRF64 n1 i1 => + match o2 with OArithRF64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRRR n1 => + match o2 with OArithRRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithRRI32 n1 i1 => + match o2 with OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRRI64 n1 i1 => + match o2 with OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithARRR n1 => + match o2 with OArithARRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithARRI32 n1 i1 => + match o2 with OArithARRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithARRI64 n1 i1 => + match o2 with OArithARRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end end. Lemma arith_op_eq_correct o1 o2: @@ -324,7 +337,8 @@ Proof. apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. Qed. - +(* TODO: rewrite control_op_eq in a robust style against the miss of a case + cf. arith_op_eq above *) Definition control_op_eq (c1 c2: control_op): ?? bool := match c1, c2 with | Oj_l l1, Oj_l l2 => phys_eq l1 l2 @@ -346,6 +360,8 @@ Proof. Qed. +(* TODO: rewrite op_eq in a robust style against the miss of a case + cf. arith_op_eq above *) Definition op_eq (o1 o2: op): ?? bool := match o1, o2 with | Arith i1, Arith i2 => arith_op_eq i1 i2 -- cgit From 50ea35fceb52c5f66ccbc4f709df3a3471b12647 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 19:28:03 +0100 Subject: added helper functions but strange idiv.c: error: __compcert_i32_sdiv: missing or incorrect declaration --- mppa_k1c/SelectOp.v | 49 ++++++++++++++++++++++++++++++++- mppa_k1c/SelectOp.vp | 48 ++++++++++++++++++++++++++++++++- mppa_k1c/SelectOpproof.v | 70 +++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 162 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v index edb07e5f..cab3259b 100644 --- a/mppa_k1c/SelectOp.v +++ b/mppa_k1c/SelectOp.v @@ -15,6 +15,7 @@ (* *) (* *********************************************************************) + (** Instruction selection for operators *) (** The instruction selection pass recognizes opportunities for using @@ -52,6 +53,48 @@ Require Import CminorSel. Local Open Scope cminorsel_scope. +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +Section SELECT. +(** Some operations on 64-bit integers are transformed into calls to + runtime library functions. The following type class collects + the names of these functions. *) + +Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default. +Definition sig_l_f := mksignature (Tlong :: nil) (Some Tfloat) cc_default. +Definition sig_l_s := mksignature (Tlong :: nil) (Some Tsingle) cc_default. +Definition sig_f_l := mksignature (Tfloat :: nil) (Some Tlong) cc_default. +Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default. +Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default. +Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default. + +Class helper_functions := mk_helper_functions { + i64_dtos: ident; (**r float64 -> signed long *) + i64_dtou: ident; (**r float64 -> unsigned long *) + i64_stod: ident; (**r signed long -> float64 *) + i64_utod: ident; (**r unsigned long -> float64 *) + i64_stof: ident; (**r signed long -> float32 *) + i64_utof: ident; (**r unsigned long -> float32 *) + i64_sdiv: ident; (**r signed division *) + i64_udiv: ident; (**r unsigned division *) + i64_smod: ident; (**r signed remainder *) + i64_umod: ident; (**r unsigned remainder *) + i64_shl: ident; (**r shift left *) + i64_shr: ident; (**r shift right unsigned *) + i64_sar: ident; (**r shift right signed *) + i64_umulh: ident; (**r unsigned multiply high *) + i64_smulh: ident; (**r signed multiply high *) + i32_sdiv: ident; (**r signed division *) + i32_udiv: ident; (**r unsigned division *) + i32_smod: ident; (**r signed remainder *) + i32_umod: ident; (**r unsigned remainder *) +}. + +Context {hf: helper_functions}. + +Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default. + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := @@ -806,7 +849,9 @@ Definition notint (e: expr) := (** ** Integer division and modulus *) -Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition divs_base (e1: expr) (e2: expr) := + Eexternal i32_sdiv sig_ii_i (e1 ::: e2 ::: Enil). + Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). @@ -1321,3 +1366,5 @@ Definition builtin_arg (e: expr) := BA e end. + +End SELECT. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 7ec694e2..3994fef9 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -15,6 +15,7 @@ (* *) (* *********************************************************************) + (** Instruction selection for operators *) (** The instruction selection pass recognizes opportunities for using @@ -52,6 +53,47 @@ Require Import CminorSel. Local Open Scope cminorsel_scope. +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +Section SELECT. +(** Some operations on 64-bit integers are transformed into calls to + runtime library functions. The following type class collects + the names of these functions. *) + +Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default. +Definition sig_l_f := mksignature (Tlong :: nil) (Some Tfloat) cc_default. +Definition sig_l_s := mksignature (Tlong :: nil) (Some Tsingle) cc_default. +Definition sig_f_l := mksignature (Tfloat :: nil) (Some Tlong) cc_default. +Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default. +Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default. +Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default. +Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default. + +Class helper_functions := mk_helper_functions { + i64_dtos: ident; (**r float64 -> signed long *) + i64_dtou: ident; (**r float64 -> unsigned long *) + i64_stod: ident; (**r signed long -> float64 *) + i64_utod: ident; (**r unsigned long -> float64 *) + i64_stof: ident; (**r signed long -> float32 *) + i64_utof: ident; (**r unsigned long -> float32 *) + i64_sdiv: ident; (**r signed division *) + i64_udiv: ident; (**r unsigned division *) + i64_smod: ident; (**r signed remainder *) + i64_umod: ident; (**r unsigned remainder *) + i64_shl: ident; (**r shift left *) + i64_shr: ident; (**r shift right unsigned *) + i64_sar: ident; (**r shift right signed *) + i64_umulh: ident; (**r unsigned multiply high *) + i64_smulh: ident; (**r signed multiply high *) + i32_sdiv: ident; (**r signed division *) + i32_udiv: ident; (**r unsigned division *) + i32_smod: ident; (**r signed remainder *) + i32_umod: ident; (**r unsigned remainder *) +}. + +Context {hf: helper_functions}. + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := @@ -294,7 +336,9 @@ Nondetfunction notint (e: expr) := (** ** Integer division and modulus *) -Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition divs_base (e1: expr) (e2: expr) := + Eexternal i32_sdiv sig_ii_i (e1 ::: e2 ::: Enil). + Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). @@ -477,3 +521,5 @@ Nondetfunction builtin_arg (e: expr) := if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e | _ => BA e end. + +End SELECT. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 57cd3d58..88eeada8 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -29,8 +29,71 @@ Require Import Cminor. Require Import Op. Require Import CminorSel. Require Import SelectOp. +Require Import Events. Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + + +(** * Axiomatization of the helper functions *) + +Definition external_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := + forall F V (ge: Genv.t F V) m, + external_call (EF_runtime name sg) ge vargs m E0 vres m. + +Definition builtin_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := + forall F V (ge: Genv.t F V) m, + external_call (EF_builtin name sg) ge vargs m E0 vres m. + +Axiom i64_helpers_correct : + (forall x z, Val.longoffloat x = Some z -> external_implements "__compcert_i64_dtos" sig_f_l (x::nil) z) + /\ (forall x z, Val.longuoffloat x = Some z -> external_implements "__compcert_i64_dtou" sig_f_l (x::nil) z) + /\ (forall x z, Val.floatoflong x = Some z -> external_implements "__compcert_i64_stod" sig_l_f (x::nil) z) + /\ (forall x z, Val.floatoflongu x = Some z -> external_implements "__compcert_i64_utod" sig_l_f (x::nil) z) + /\ (forall x z, Val.singleoflong x = Some z -> external_implements "__compcert_i64_stof" sig_l_s (x::nil) z) + /\ (forall x z, Val.singleoflongu x = Some z -> external_implements "__compcert_i64_utof" sig_l_s (x::nil) z) + /\ (forall x, builtin_implements "__builtin_negl" sig_l_l (x::nil) (Val.negl x)) + /\ (forall x y, builtin_implements "__builtin_addl" sig_ll_l (x::y::nil) (Val.addl x y)) + /\ (forall x y, builtin_implements "__builtin_subl" sig_ll_l (x::y::nil) (Val.subl x y)) + /\ (forall x y, builtin_implements "__builtin_mull" sig_ii_l (x::y::nil) (Val.mull' x y)) + /\ (forall x y z, Val.divls x y = Some z -> external_implements "__compcert_i64_sdiv" sig_ll_l (x::y::nil) z) + /\ (forall x y z, Val.divlu x y = Some z -> external_implements "__compcert_i64_udiv" sig_ll_l (x::y::nil) z) + /\ (forall x y z, Val.modls x y = Some z -> external_implements "__compcert_i64_smod" sig_ll_l (x::y::nil) z) + /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__compcert_i64_umod" sig_ll_l (x::y::nil) z) + /\ (forall x y, external_implements "__compcert_i64_shl" sig_li_l (x::y::nil) (Val.shll x y)) + /\ (forall x y, external_implements "__compcert_i64_shr" sig_li_l (x::y::nil) (Val.shrlu x y)) + /\ (forall x y, external_implements "__compcert_i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)) + /\ (forall x y, external_implements "__compcert_i64_umulh" sig_ll_l (x::y::nil) (Val.mullhu x y)) + /\ (forall x y, external_implements "__compcert_i64_smulh" sig_ll_l (x::y::nil) (Val.mullhs x y)) + /\ (forall x y z, Val.divls x y = Some z -> external_implements "__compcert_i32_sdiv" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.divlu x y = Some z -> external_implements "__compcert_i32_udiv" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.modls x y = Some z -> external_implements "__compcert_i32_smod" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__compcert_i32_umod" sig_ii_i (x::y::nil) z) +. + +Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := + (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). + +Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := + helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l + /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l + /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f + /\ helper_declared p i64_utod "__compcert_i64_utod" sig_l_f + /\ helper_declared p i64_stof "__compcert_i64_stof" sig_l_s + /\ helper_declared p i64_utof "__compcert_i64_utof" sig_l_s + /\ helper_declared p i64_sdiv "__compcert_i64_sdiv" sig_ll_l + /\ helper_declared p i64_udiv "__compcert_i64_udiv" sig_ll_l + /\ helper_declared p i64_smod "__compcert_i64_smod" sig_ll_l + /\ helper_declared p i64_umod "__compcert_i64_umod" sig_ll_l + /\ helper_declared p i64_shl "__compcert_i64_shl" sig_li_l + /\ helper_declared p i64_shr "__compcert_i64_shr" sig_li_l + /\ helper_declared p i64_sar "__compcert_i64_sar" sig_li_l + /\ helper_declared p i64_umulh "__compcert_i64_umulh" sig_ll_l + /\ helper_declared p i64_smulh "__compcert_i64_smulh" sig_ll_l + /\ helper_declared p i32_sdiv "__compcert_i32_sdiv" sig_ii_i + /\ helper_declared p i32_udiv "__compcert_i32_udiv" sig_ii_i + /\ helper_declared p i32_smod "__compcert_i32_smod" sig_ii_i + /\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i. (** * Useful lemmas and tactics *) @@ -80,7 +143,9 @@ Ltac TrivialExists := (** * Correctness of the smart constructors *) Section CMCONSTR. - +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. Variable ge: genv. Variable sp: val. Variable e: env. @@ -549,8 +614,7 @@ Theorem eval_divs_base: Val.divs x y = Some z -> exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold divs_base. exists z; split. EvalOp. auto. -Qed. +Admitted. Theorem eval_mods_base: forall le a b x y z, -- cgit From 4833f4a05023b57cba859a652924d1cd058efcea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 19:42:03 +0100 Subject: reverse madd --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 2 ++ 2 files changed, 4 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index e34e7c32..22211167 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -88,6 +88,8 @@ Nondetfunction add (e1: expr) (e2: expr) := addimm n2 (Eop Oadd (t1:::t2:::Enil)) | t1, (Eop Omul (t2:::t3:::Enil)) => Eop Omadd (t1:::t2:::t3:::Enil) + | (Eop Omul (t2:::t3:::Enil)), t1 => + Eop Omadd (t1:::t2:::t3:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index d7ae92dc..fe678383 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -184,6 +184,8 @@ Proof. repeat rewrite Val.add_assoc. reflexivity. - (* Omadd *) subst. TrivialExists. + - (* Omadd *) + subst. rewrite Val.add_commut. TrivialExists. - TrivialExists. Qed. -- cgit From f2e7e95f6e113edbcb80618a0f3b4c15caa6f5cd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 19:52:01 +0100 Subject: fix classes for madd --- mppa_k1c/PostpassSchedulingOracle.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b02bc6ca..f7702a9d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -524,12 +524,12 @@ let rec_to_usage r = and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw | Maddw -> + | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Maddd -> + | 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) @@ -549,10 +549,10 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw -> (match encoding with None -> mau + | Mulw| Maddw -> (match encoding with None -> mau | Some U6 | Some S10 | Some U27L5 -> mau_x | _ -> raise InvalidEncoding) - | Muld -> (match encoding with None | Some U6 | Some S10 -> mau + | Muld | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop -- cgit From ae571e2467e977f03044d750568f6528d8d64e43 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 20:41:23 +0100 Subject: mul immediate begin --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmblock.v | 4 ++++ mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/NeedOp.v | 2 ++ mppa_k1c/Op.v | 9 +++++++-- mppa_k1c/PostpassSchedulingOracle.ml | 6 ++++-- mppa_k1c/TargetPrinter.ml | 4 ++++ mppa_k1c/ValueAOp.v | 1 + 8 files changed, 28 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1a57e554..0ca554ab 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -177,6 +177,7 @@ Inductive instruction : Type := | 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 *) @@ -197,6 +198,7 @@ Inductive instruction : Type := (** 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 *) @@ -319,6 +321,7 @@ Definition basic_to_instruction (b: basic) := (* RRI32 *) | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 Asmblock.Pmuliw rd rs imm => Pmuliw rd rs imm | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm | PArithRRI32 Asmblock.Pnandiw rd rs imm => Pnandiw rd rs imm | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm @@ -338,6 +341,7 @@ Definition basic_to_instruction (b: basic) := (* RRI64 *) | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm | PArithRRI64 Asmblock.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 Asmblock.Pmulil rd rs imm => Pmulil rd rs imm | PArithRRI64 Asmblock.Pandil rd rs imm => Pandil rd rs imm | PArithRRI64 Asmblock.Pnandil rd rs imm => Pnandil rd rs imm | PArithRRI64 Asmblock.Poril rd rs imm => Poril rd rs imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index b3e1532d..386106d6 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -376,6 +376,7 @@ Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) + | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) | Poriw (**r or imm word *) @@ -396,6 +397,7 @@ Inductive arith_name_rri32 : Type := Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) + | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) | Poril (**r or immediate long *) @@ -1168,6 +1170,7 @@ Definition arith_eval_rri32 n v i := match n with | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) + | Pmuliw => Val.mul v (Vint i) | Pandiw => Val.and v (Vint i) | Pnandiw => Val.notint (Val.and v (Vint i)) | Poriw => Val.or v (Vint i) @@ -1189,6 +1192,7 @@ Definition arith_eval_rri64 n v i := match n with | Pcompil c => compare_long c v (Vlong i) | Paddil => Val.addl v (Vlong i) + | Pmulil => Val.mull v (Vlong i) | Pandil => Val.andl v (Vlong i) | Pnandil => Val.notl (Val.andl v (Vlong i)) | Poril => Val.orl v (Vlong i) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e05f92a7..f50b7d4a 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1382,6 +1382,7 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" + | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" | Poriw => "Poriw" @@ -1403,6 +1404,7 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" + | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" | Poril => "Poril" diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 801a520e..c7b59a34 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -45,6 +45,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oneg => op1 (modarith nv) | Osub => op2 (default nv) | Omul => op2 (modarith nv) + | Omulimm _ => op1 (modarith nv) | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) | Oand => op2 (bitwise nv) | Oandimm n => op1 (andimm nv n) @@ -171,6 +172,7 @@ Proof. - apply add_sound; auto with na. - apply neg_sound; auto. - apply mul_sound; auto. +- apply mul_sound; auto with na. - apply and_sound; auto. - apply andimm_sound; auto. - apply notint_sound; apply and_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c56a9649..04081158 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -70,6 +70,7 @@ Inductive operation : Type := | Oneg (**r [rd = - r1] *) | Osub (**r [rd = r1 - r2] *) | Omul (**r [rd = r1 * r2] *) + | Omulimm (n: int) (**r [rd = r1 * n] *) | Omulhs (**r [rd = high part of r1 * r2, signed] *) | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) | Odiv (**r [rd = r1 / r2] (signed) *) @@ -268,6 +269,7 @@ Definition eval_operation | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 @@ -456,6 +458,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oneg => (Tint :: nil, Tint) | Osub => (Tint :: Tint :: nil, Tint) | Omul => (Tint :: Tint :: nil, Tint) + | Omulimm _ => (Tint :: nil, Tint) | Omulhs => (Tint :: Tint :: nil, Tint) | Omulhu => (Tint :: Tint :: nil, Tint) | Odiv => (Tint :: Tint :: nil, Tint) @@ -623,8 +626,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* neg, sub *) - destruct v0... - unfold Val.sub. destruct v0; destruct v1... - (* mul, mulhs, mulhu *) + (* mul, mulimm, mulhs, mulhu *) - destruct v0; destruct v1... + - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... (* div, divu *) @@ -1124,8 +1128,9 @@ Proof. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. - (* mul, mulhs, mulhu *) + (* mul, mulimm, mulhs, mulhu *) - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. (* div, divu *) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f7702a9d..e1948a03 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -95,6 +95,7 @@ let arith_rrr_str = function let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" + | Pmuliw -> "Pmuliw" | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" | Poriw -> "Poriw" @@ -114,6 +115,7 @@ let arith_rri32_str = function let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" + | Pmulil -> "Pmulil" | Pandil -> "Pandil" | Pnandil -> "Pnandil" | Poril -> "Poril" @@ -437,8 +439,8 @@ let ab_inst_to_real = function | "Pcompl" | "Pcompil" -> Compd | "Pfcompw" -> Fcompw | "Pfcompl" -> Fcompd - | "Pmulw" -> Mulw - | "Pmull" -> Muld + | "Pmulw" | "Pmuliw" -> Mulw + | "Pmull" | "Pmulil" -> Muld | "Porw" | "Poriw" -> Orw | "Pnorw" | "Pnoriw" -> Norw | "Porl" | "Poril" -> Ord diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5c5d6c79..69824852 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -442,6 +442,8 @@ module Target (*: TARGET*) = 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 + | Pmuliw (rd, rs, imm) -> + fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pnandiw (rd, rs, imm) -> @@ -481,6 +483,8 @@ 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 + | 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; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnandil (rd, rs, imm) -> assert Archi.ptr64; diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index a92358ca..3bb25807 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -57,6 +57,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oneg, v1::nil => neg v1 | Osub, v1::v2::nil => sub v1 v2 | Omul, v1::v2::nil => mul v1 v2 + | Omulimm n, v1::nil => mul v1 (I n) | Omulhs, v1::v2::nil => mulhs v1 v2 | Omulhu, v1::v2::nil => mulhu v1 v2 | Odiv, v1::v2::nil => divs v1 v2 -- cgit From 9adb576998f3b2017db5c062b459449e1721579a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 21:31:20 +0100 Subject: mul immediate --- mppa_k1c/Asmblockgen.v | 8 ++++++++ mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 5 +++++ mppa_k1c/SelectOp.vp | 2 +- mppa_k1c/SelectOpproof.v | 4 ++-- mppa_k1c/ValueAOp.v | 1 + 6 files changed, 18 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 1646ff94..ba01883d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -85,6 +85,7 @@ Definition opimm32 (op: arith_name_rrr) end. Definition addimm32 := opimm32 Paddw Paddiw. +Definition mulimm32 := opimm32 Pmulw Pmuliw. Definition andimm32 := opimm32 Pandw Pandiw. Definition nandimm32 := opimm32 Pnandw Pnandiw. Definition orimm32 := opimm32 Porw Poriw. @@ -109,6 +110,7 @@ Definition opimm64 (op: arith_name_rrr) end. Definition addimm64 := opimm64 Paddl Paddil. +Definition mulimm64 := opimm64 Pmull Pmulil. Definition orimm64 := opimm64 Porl Poril. Definition andimm64 := opimm64 Pandl Pandil. Definition xorimm64 := opimm64 Pxorl Pxoril. @@ -420,6 +422,9 @@ Definition transl_op | 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) + | Omulimm n, a1 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; + OK (mulimm32 rd rs1 n ::i k) | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") (* Normalement pas émis *) | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (* Normalement pas émis *) | Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") @@ -546,6 +551,9 @@ Definition transl_op | 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) + | Omullimm n, a1 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; + OK (mulimm64 rd rs1 n ::i k) | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") (* Normalement pas émis *) | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") (* Normalement pas émis *) | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") (* Géré par fonction externe *) diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index c7b59a34..68f43894 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -81,6 +81,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onegl => op1 (default nv) | Osubl => op2 (default nv) | Omull => op2 (default nv) + | Omullimm _ => op1 (default nv) | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) | Oandl => op2 (default nv) | Oandlimm n => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 04081158..0e9a7af9 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -115,6 +115,7 @@ Inductive operation : Type := | Onegl (**r [rd = - r1] *) | Osubl (**r [rd = r1 - r2] *) | Omull (**r [rd = r1 * r2] *) + | Omullimm (n: int64) (**r [rd = r1 * n] *) | Omullhs (**r [rd = high part of r1 * r2, signed] *) | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) | Odivl (**r [rd = r1 / r2] (signed) *) @@ -314,6 +315,7 @@ Definition eval_operation | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) | Omull, v1::v2::nil => Some (Val.mull v1 v2) + | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) | Odivl, v1::v2::nil => Val.divls v1 v2 @@ -503,6 +505,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Onegl => (Tlong :: nil, Tlong) | Osubl => (Tlong :: Tlong :: nil, Tlong) | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omullimm _ => (Tlong :: nil, Tlong) | Omullhs => (Tlong :: Tlong :: nil, Tlong) | Omullhu => (Tlong :: Tlong :: nil, Tlong) | Odivl => (Tlong :: Tlong :: nil, Tlong) @@ -700,6 +703,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (eq_block b b0)... (* mull, mullhs, mullhu *) - destruct v0; destruct v1... + - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... (* divl, divlu *) @@ -1205,6 +1209,7 @@ Proof. - apply Val.subl_inject; auto. (* mull, mullhs, mullhu *) - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. (* divl, divlu *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 22211167..d87c837e 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -173,7 +173,7 @@ Definition mulimm_base (n1: int) (e2: expr) := | i :: j :: nil => Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) | _ => - Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + Eop (Omulimm n1) (e2 ::: Enil) end. Nondetfunction mulimm (n1: int) (e2: expr) := diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index fe678383..a8889430 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -301,7 +301,7 @@ Proof. generalize (Int.one_bits_decomp n). generalize (Int.one_bits_range n). destruct (Int.one_bits n). - - intros. auto. + - intros. TrivialExists. - destruct l. + intros. rewrite H1. simpl. rewrite Int.add_zero. @@ -319,7 +319,7 @@ Proof. rewrite Val.mul_add_distr_r. repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. simpl. repeat rewrite H0; auto with coqlib. - intros. auto. + intros. TrivialExists. Qed. Theorem eval_mulimm: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 3bb25807..b43c4d78 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -101,6 +101,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Onegl, v1::nil => negl v1 | Osubl, v1::v2::nil => subl v1 v2 | Omull, v1::v2::nil => mull v1 v2 + | Omullimm n, v1::nil => mull v1 (L n) | Omullhs, v1::v2::nil => mullhs v1 v2 | Omullhu, v1::v2::nil => mullhu v1 v2 | Odivl, v1::v2::nil => divls v1 v2 -- cgit From 2af07d6a328f73a32bc2c768e3108dd3db393ed1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 19 Mar 2019 21:50:25 +0100 Subject: mul+madd immediate --- mppa_k1c/Asmblockgen.v | 19 ++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 6 +++++- 4 files changed, 28 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ba01883d..80b712e3 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -524,6 +524,11 @@ Definition transl_op do r2 <- ireg_of a2; do r3 <- ireg_of a3; OK (Pmaddw r1 r2 r3 ::i k) + | Omaddimm n, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + OK (Pmaddiw r1 r2 n ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -636,7 +641,19 @@ Definition transl_op Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i Paddl RTMP rs RTMP ::i Psrail rd RTMP n ::i k) - + (* FIXME + | Omaddl, 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 (Pmaddl r1 r2 r3 ::i k) + | Omaddlimm n, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + OK (Pmaddil r1 r2 n ::i k) +*) | Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs ::i k) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index e1948a03..f4732ee4 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -453,7 +453,7 @@ let ab_inst_to_real = function | "Psrll" | "Psrlil" -> Srld | "Psllw" | "Pslliw" -> Sllw | "Proriw" -> Rorw - | "Pmaddw" -> Maddw + | "Pmaddw" | "Pmaddiw" -> Maddw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pnxorw" | "Pnxoriw" -> Nxorw diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d87c837e..e4d65ced 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -90,6 +90,10 @@ Nondetfunction add (e1: expr) (e2: expr) := Eop Omadd (t1:::t2:::t3:::Enil) | (Eop Omul (t2:::t3:::Enil)), t1 => Eop Omadd (t1:::t2:::t3:::Enil) + | 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 Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index a8889430..94d162a2 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -184,7 +184,11 @@ Proof. repeat rewrite Val.add_assoc. reflexivity. - (* Omadd *) subst. TrivialExists. - - (* Omadd *) + - (* Omadd rev *) + subst. rewrite Val.add_commut. TrivialExists. + - (* Omaddimm *) + subst. TrivialExists. + - (* Omaddimm rev *) subst. rewrite Val.add_commut. TrivialExists. - TrivialExists. Qed. -- cgit From 947a61ee5d1f972054157b66a094d6a356a91654 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 09:29:52 +0100 Subject: maddl declared --- mppa_k1c/NeedOp.v | 40 ++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Op.v | 27 ++++++++++----------------- mppa_k1c/ValueAOp.v | 2 ++ 3 files changed, 52 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 68f43894..2577370c 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -105,6 +105,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshrlimm n => op1 (default nv) | Oshrluimm n => op1 (default nv) | Oshrxlimm n => op1 (default nv) + | Omaddl => op3 (default nv) + | Omaddlimm n => op2 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) @@ -156,6 +158,39 @@ Proof. eapply default_needs_of_condition_sound; eauto. Qed. +Lemma addl_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.addl v1 v2) (Val.addl w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.addl. + destruct v1; destruct v2; trivial; destruct Archi.ptr64; trivial. + - apply Val.addl_lessdef; trivial. +Qed. + + +Lemma mull_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.mull v1 v2) (Val.mull w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.mull. + destruct v1; destruct v2; trivial. + - unfold Val.mull. + destruct v1; destruct v2; trivial. + inv H. inv H0. + trivial. +Qed. + +Remark default_idem: forall nv, default (default nv) = default nv. +Proof. + destruct nv; simpl; trivial. +Qed. + Lemma needs_of_operation_sound: forall op args v nv args', eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> @@ -198,6 +233,11 @@ 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. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 0e9a7af9..c4338857 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -146,10 +146,8 @@ Inductive operation : Type := | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) - (* FIXME | Omaddl (**r [rd = rd + r1 * r2] *) | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) -*) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -346,11 +344,8 @@ Definition eval_operation | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) | 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))) - *) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -536,10 +531,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshrlu => (Tlong :: Tint :: nil, Tlong) | Oshrluimm _ => (Tlong :: nil, Tlong) | Oshrxlimm _ => (Tlong :: nil, Tlong) - (* FIXME | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) -*) + | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) @@ -753,10 +747,11 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... (* shrxl *) - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... - (* FIXME (* maddl, maddlim *) - - destruct v0; destruct v1; destruct v2... - - destruct v0; destruct v1... *) + - destruct v0; destruct v1; destruct v2; simpl; trivial. + destruct Archi.ptr64; simpl; trivial. + - destruct v0; destruct v1; simpl; trivial. + destruct Archi.ptr64; simpl; trivial. (* negf, absf *) - destruct v0... - destruct v0... @@ -1265,13 +1260,11 @@ Proof. - inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. - (* - (* maddl, maddlim *) - - inv H2; inv H3; inv H4; simpl; auto; simpl. - destruct Archi.ptr64; trivial. - s - - inv H2; inv H4; simpl; auto. - *) + (* maddl, maddlimm *) + - apply Val.addl_inject; auto. + inv H2; inv H3; inv H4; simpl; auto. + - apply Val.addl_inject; auto. + inv H4; inv H2; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index b43c4d78..fb1977ea 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -132,6 +132,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshrlu, v1::v2::nil => shrlu v1 v2 | Oshrluimm n, v1::nil => shrlu v1 (I n) | 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)) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 -- cgit From 5487cf64164eeea716e3ad140977aa73ccbe00ce Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 09:35:06 +0100 Subject: maddl gets to assembly --- mppa_k1c/Asmblockgen.v | 2 -- 1 file changed, 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 80b712e3..b4532dc4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -641,7 +641,6 @@ Definition transl_op Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i Paddl RTMP rs RTMP ::i Psrail rd RTMP n ::i k) - (* FIXME | Omaddl, a1 :: a2 :: a3 :: nil => assertion (mreg_eq a1 res); do r1 <- ireg_of a1; @@ -653,7 +652,6 @@ Definition transl_op do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pmaddil r1 r2 n ::i k) -*) | Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs ::i k) -- cgit From a0c25ff1259a8373fb71e780f70d28916c321612 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 09:49:45 +0100 Subject: maddl / maddlim are synthesized (but not for pointers it seems) --- mppa_k1c/Machregs.v | 2 +- mppa_k1c/SelectLong.vp | 8 ++++++++ mppa_k1c/SelectLongproof.v | 4 ++++ 3 files changed, 13 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 9f0f6a4d..25048809 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -210,7 +210,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ => true | _ => false end. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 07ebf1a2..3a17ab17 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -88,6 +88,14 @@ Nondetfunction addl (e1: expr) (e2: expr) := addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) | t1, Eop (Oaddlimm n2) (t2:::Enil) => addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | t1, (Eop Omull (t2:::t3:::Enil)) => + Eop Omaddl (t1:::t2:::t3:::Enil) + | (Eop Omull (t2:::t3:::Enil)), t1 => + Eop Omaddl (t1:::t2:::t3:::Enil) + | t1, (Eop (Omullimm n) (t2:::Enil)) => + Eop (Omaddlimm n) (t1:::t2:::Enil) + | (Eop (Omullimm n) (t2:::Enil)), t1 => + Eop (Omaddlimm n) (t1:::t2:::Enil) | _, _ => Eop Oaddl (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 27681875..4723278a 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -185,6 +185,10 @@ Proof. with (Val.addl (Val.addl x v1) (Vlong n2)). apply eval_addlimm. EvalOp. repeat rewrite Val.addl_assoc. reflexivity. + - subst. TrivialExists. + - subst. rewrite Val.addl_commut. TrivialExists. + - subst. TrivialExists. + - subst. rewrite Val.addl_commut. TrivialExists. - TrivialExists. Qed. -- cgit From e1da7c1c79ce2286f5b93cc3f336c9e10b195f0b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 11:29:18 +0100 Subject: les divisions entieres passent --- mppa_k1c/SelectOp.vp | 11 ++++++++--- mppa_k1c/SelectOpproof.v | 9 +++------ 2 files changed, 11 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 163f0c22..b2ce1fef 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -347,9 +347,14 @@ Nondetfunction notint (e: expr) := Definition divs_base (e1: expr) (e2: expr) := Eexternal i32_sdiv sig_ii_i (e1 ::: e2 ::: Enil). -Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). -Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). -Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). +Definition mods_base (e1: expr) (e2: expr) := + Eexternal i32_smod sig_ii_i (e1 ::: e2 ::: Enil). + +Definition divu_base (e1: expr) (e2: expr) := + Eexternal i32_udiv sig_ii_i (e1 ::: e2 ::: Enil). + +Definition modu_base (e1: expr) (e2: expr) := + Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). Definition shrximm (e1: expr) (n2: int) := if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7c0dea8a..c6fbef6b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -631,8 +631,7 @@ Theorem eval_mods_base: Val.mods x y = Some z -> exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold mods_base. exists z; split. EvalOp. auto. -Qed. +Admitted. Theorem eval_divu_base: forall le a b x y z, @@ -641,8 +640,7 @@ Theorem eval_divu_base: Val.divu x y = Some z -> exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold divu_base. exists z; split. EvalOp. auto. -Qed. +Admitted. Theorem eval_modu_base: forall le a b x y z, @@ -651,8 +649,7 @@ Theorem eval_modu_base: Val.modu x y = Some z -> exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold modu_base. exists z; split. EvalOp. auto. -Qed. +Admitted. Theorem eval_shrximm: forall le a n x z, -- cgit From 7bd5d66520bfae2bdef6573a40798a5d6375be79 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Mar 2019 11:30:21 +0100 Subject: Proving eval_divs_base --- mppa_k1c/SelectOpproof.v | 53 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 47 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 88eeada8..1626e3fe 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -65,10 +65,10 @@ Axiom i64_helpers_correct : /\ (forall x y, external_implements "__compcert_i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)) /\ (forall x y, external_implements "__compcert_i64_umulh" sig_ll_l (x::y::nil) (Val.mullhu x y)) /\ (forall x y, external_implements "__compcert_i64_smulh" sig_ll_l (x::y::nil) (Val.mullhs x y)) - /\ (forall x y z, Val.divls x y = Some z -> external_implements "__compcert_i32_sdiv" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.divlu x y = Some z -> external_implements "__compcert_i32_udiv" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.modls x y = Some z -> external_implements "__compcert_i32_smod" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__compcert_i32_umod" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.divs x y = Some z -> external_implements "__compcert_i32_sdiv" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.divu x y = Some z -> external_implements "__compcert_i32_udiv" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.mods x y = Some z -> external_implements "__compcert_i32_smod" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.modu x y = Some z -> external_implements "__compcert_i32_umod" sig_ii_i (x::y::nil) z) . Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := @@ -146,11 +146,50 @@ Section CMCONSTR. Variable prog: program. Variable hf: helper_functions. Hypothesis HELPERS: helper_functions_declared prog hf. -Variable ge: genv. +Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable m: mem. +(* Helper lemmas - from SplitLongproof.v *) + +Ltac UseHelper := decompose [Logic.and] i64_helpers_correct; eauto. +Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. + +Lemma eval_helper: + forall le id name sg args vargs vres, + eval_exprlist ge sp e m le args vargs -> + helper_declared prog id name sg -> + external_implements name sg vargs vres -> + eval_expr ge sp e m le (Eexternal id sg args) vres. +Proof. + intros. + red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q). + rewrite <- Genv.find_funct_ptr_iff in Q. + econstructor; eauto. +Qed. + +Corollary eval_helper_1: + forall le id name sg arg1 varg1 vres, + eval_expr ge sp e m le arg1 varg1 -> + helper_declared prog id name sg -> + external_implements name sg (varg1::nil) vres -> + eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres. +Proof. + intros. eapply eval_helper; eauto. constructor; auto. constructor. +Qed. + +Corollary eval_helper_2: + forall le id name sg arg1 arg2 varg1 varg2 vres, + eval_expr ge sp e m le arg1 varg1 -> + eval_expr ge sp e m le arg2 varg2 -> + helper_declared prog id name sg -> + external_implements name sg (varg1::varg2::nil) vres -> + eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. +Proof. + intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor. +Qed. + (** We now show that the code generated by "smart constructor" functions such as [Selection.notint] behaves as expected. Continuing the [notint] example, we show that if the expression [e] @@ -614,7 +653,9 @@ Theorem eval_divs_base: Val.divs x y = Some z -> exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. Proof. -Admitted. + intros; unfold divs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. Theorem eval_mods_base: forall le a b x y z, -- cgit From 6462da4e8f25ce5df951635828901ad0180e9958 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Mar 2019 12:00:16 +0100 Subject: Integrating Asmvliw.v in the proof chain --- mppa_k1c/Asm.v | 6 +++--- mppa_k1c/Asmvliw.v | 5 ++--- mppa_k1c/PostpassSchedulingproof.v | 34 ++++++++++++++++++++++++---------- 3 files changed, 29 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 31bc855d..0d4906b9 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -30,7 +30,7 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. -Require Import Asmblock. +Require Import Asmvliw. Require Import Linking. Require Import Errors. @@ -416,7 +416,7 @@ Definition program_proj (p: program) : Asmblock.program := End RELSEM. -Definition semantics (p: program) := Asmblock.semantics (program_proj p). +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). (** Determinacy of the [Asm] semantics. *) @@ -547,7 +547,7 @@ Proof (Genv.senv_match TRANSF). Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (semantics tprog). + 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. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 5b58118b..36c68acd 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -31,7 +31,8 @@ Require Import Locations. Require Stacklayout. Require Import Conventions. Require Import Errors. -Require Import Asmblock. +Require Export Asmblock. +Require Import Sorting.Permutation. Local Open Scope asm. @@ -236,8 +237,6 @@ Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rs: regset) (m: 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 m. -Require Import Sorting.Permutation. - Definition parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem) (o: outcome): Prop := exists bdy1 bdy2, Permutation (bdy1++bdy2) (body b) /\ o=match parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m with diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 7d6d9a7a..6fff3117 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -237,7 +237,7 @@ Proof. rewrite <- Zplus_mod. auto. Qed. -Section PRESERVATION. +Section PRESERVATION_ASMBLOCK. Variables prog tprog: program. Hypothesis TRANSL: match_prog prog tprog. @@ -668,23 +668,37 @@ Proof. - apply transf_step_correct. Qed. -(* TODO: +End PRESERVATION_ASMBLOCK. + Require Import Asmvliw. -Theorem transf_program_correct: +Section PRESERVATION_ASMVLIW. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct_Asmvliw: forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). Proof. - eapply forward_simulation_one_one. (* FIXME *) Admitted. -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmvliw.semantics tprog). -Proof. - eapply forward_simulation_compose. (* FIXME *) -Admitted. +End PRESERVATION_ASMVLIW. -*) +Section PRESERVATION. +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmvliw.semantics tprog). +Proof. + eapply compose_forward_simulations. + eapply transf_program_correct_Asmblock; eauto. + eapply transf_program_correct_Asmvliw; eauto. +Qed. End PRESERVATION. -- cgit From 3718f2f520fc9a4dec2e9c1ac6eaf71f36f4f8a1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 12:25:02 +0100 Subject: begin float division --- mppa_k1c/SelectOp.vp | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index b2ce1fef..80eb641c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -535,4 +535,8 @@ Nondetfunction builtin_arg (e: expr) := | _ => BA e end. +(* float division *) + +Definition divfbase (e1: expr) (e2: expr) := + Eop Odivf (e1 ::: e2 ::: Enil). End SELECT. -- cgit From 2638a022276c932ed00dc3f64b0e58bc0114a3d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 12:55:03 +0100 Subject: la division flottante fonctionne --- mppa_k1c/SelectOp.vp | 13 +++++++++++-- mppa_k1c/SelectOpproof.v | 16 ++++++++++++++++ 2 files changed, 27 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 80eb641c..19712d2f 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -69,6 +69,8 @@ Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_defau Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default. Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default. Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default. +Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default. +Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default. Class helper_functions := mk_helper_functions { i64_dtos: ident; (**r float64 -> signed long *) @@ -90,6 +92,8 @@ Class helper_functions := mk_helper_functions { i32_udiv: ident; (**r unsigned division *) i32_smod: ident; (**r signed remainder *) i32_umod: ident; (**r unsigned remainder *) + f64_div: ident; (**float division*) + f32_div: ident; (**float division*) }. Context {hf: helper_functions}. @@ -537,6 +541,11 @@ Nondetfunction builtin_arg (e: expr) := (* float division *) -Definition divfbase (e1: expr) (e2: expr) := - Eop Odivf (e1 ::: e2 ::: Enil). +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) := + (* Eop Odivf (e1 ::: e2 ::: Enil). *) + Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). End SELECT. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 5a3f4521..ca6c342a 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1070,4 +1070,20 @@ Proof. - constructor; auto. Qed. +(* floating-point division *) +Theorem eval_divf_base: + 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 (divf_base a b) v /\ Val.lessdef (Val.divf x y) v. +Proof. +Admitted. + +Theorem eval_divfs_base: + 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_base a b) v /\ Val.lessdef (Val.divfs x y) v. +Proof. +Admitted. End CMCONSTR. -- cgit From 85dc3bff6792d0cc2e1f7b3cc2446cd01428907b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 20 Mar 2019 13:33:45 +0100 Subject: Proof of div32/mod32/divf32/divf64 lemmas --- mppa_k1c/SelectOpproof.v | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index ca6c342a..a4a5f72b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -69,6 +69,8 @@ Axiom i64_helpers_correct : /\ (forall x y z, Val.divu x y = Some z -> external_implements "__compcert_i32_udiv" sig_ii_i (x::y::nil) z) /\ (forall x y z, Val.mods x y = Some z -> external_implements "__compcert_i32_smod" sig_ii_i (x::y::nil) z) /\ (forall x y z, Val.modu x y = Some z -> external_implements "__compcert_i32_umod" sig_ii_i (x::y::nil) z) + /\ (forall x y z, Val.divfs x y = z -> external_implements "__compcert_f32_div" sig_ss_s (x::y::nil) z) + /\ (forall x y z, Val.divf x y = z -> external_implements "__compcert_f64_div" sig_ff_f (x::y::nil) z) . Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := @@ -93,7 +95,10 @@ Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) /\ helper_declared p i32_sdiv "__compcert_i32_sdiv" sig_ii_i /\ helper_declared p i32_udiv "__compcert_i32_udiv" sig_ii_i /\ helper_declared p i32_smod "__compcert_i32_smod" sig_ii_i - /\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i. + /\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i + /\ helper_declared p f32_div "__compcert_f32_div" sig_ss_s + /\ helper_declared p f64_div "__compcert_f64_div" sig_ff_f +. (** * Useful lemmas and tactics *) @@ -672,7 +677,9 @@ Theorem eval_mods_base: Val.mods x y = Some z -> exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. Proof. -Admitted. + intros; unfold mods_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. Theorem eval_divu_base: forall le a b x y z, @@ -681,7 +688,9 @@ Theorem eval_divu_base: Val.divu x y = Some z -> exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. -Admitted. + intros; unfold divu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. Theorem eval_modu_base: forall le a b x y z, @@ -690,7 +699,9 @@ Theorem eval_modu_base: Val.modu x y = Some z -> exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. Proof. -Admitted. + intros; unfold modu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. Theorem eval_shrximm: forall le a n x z, @@ -1077,7 +1088,9 @@ Theorem eval_divf_base: eval_expr ge sp e m le b y -> exists v, eval_expr ge sp e m le (divf_base a b) v /\ Val.lessdef (Val.divf x y) v. Proof. -Admitted. + intros; unfold divf_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. Theorem eval_divfs_base: forall le a b x y, @@ -1085,5 +1098,7 @@ Theorem eval_divfs_base: eval_expr ge sp e m le b y -> exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v. Proof. -Admitted. + intros; unfold divfs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. End CMCONSTR. -- cgit From ab5528fb4caf637a0c7014d943302198079e7c20 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 17:01:25 +0100 Subject: XLeroy's suggested fix for shared float/int register file. --- mppa_k1c/Conventions1.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 59159f61..d41f1095 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -47,13 +47,13 @@ Definition int_caller_save_regs := :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 :: R62 :: R63 :: nil. -Definition float_caller_save_regs := rev int_caller_save_regs. +Definition float_caller_save_regs : list mreg := nil. Definition int_callee_save_regs := (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. -Definition float_callee_save_regs := rev int_callee_save_regs. +Definition float_callee_save_regs : list mreg := nil. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -- cgit From e25099690ddfc45579c318940f3304ab6400135c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 20 Mar 2019 17:50:16 +0100 Subject: premier decoupage --- mppa_k1c/PostpassSchedulingproof.v | 58 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 56 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 6fff3117..25bdf244 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -670,7 +670,7 @@ Qed. End PRESERVATION_ASMBLOCK. -Require Import Asmvliw. +Require Import Asmvliw List. Section PRESERVATION_ASMVLIW. @@ -679,10 +679,64 @@ Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. + +Lemma transf_blocks_checks_all_bundles lbb bundles: + transf_blocks (lbb : list bblock) = OK bundles -> + List.Forall (fun bb => verify_par_bblock bb = OK tt) bundles. +Proof. +Admitted. + +Lemma all_bundles_are_checked b ofs f bundle: + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + verify_par_bblock bundle = OK tt. +Proof. + unfold match_prog, match_program, match_program_gen in TRANSL. + (* HOW CAN WE PROVE THIS FROM transf_blocks_checks_all_bundles ?? *) +Admitted. + +Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + verify_par_bblock bundle = OK tt -> + parexec_bblock (globalenv (semantics tprog)) f bundle rs m o -> o = Next rs' m'. +Proof. +Admitted. + +Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m' o: + (* rs PC = Vptr b ofs -> *) (* needed somewhere ? *) + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + parexec_bblock (globalenv (semantics tprog)) f bundle rs m o -> o = Next rs' m'. +Proof. + intros; eapply checked_bundles_are_parexec_equiv; eauto. + eapply all_bundles_are_checked; eauto. +Qed. + +Lemma seqexec_parexec_wio b ofs f bundle rs rs' m m': + (* rs PC = Vptr b ofs -> *) (* needed somewhere ? *) + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + parexec_wio_bblock (globalenv (semantics tprog)) f bundle rs m = Next rs' m'. +Proof. + intros; erewrite <- seqexec_parexec_equiv; eauto. + eapply parexec_bblock_write_in_order. +Qed. + + Theorem transf_program_correct_Asmvliw: forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). Proof. -Admitted. + eapply forward_simulation_step with (match_states:=fun (s1:Asmblock.state) s2 => s1=s2); eauto. + - intros; subst; auto. + - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. + + eapply exec_step_internal; eauto. + eapply seqexec_parexec_wio; eauto. + intros; eapply seqexec_parexec_equiv; eauto. + + eapply exec_step_builtin; eauto. + + eapply exec_step_external; eauto. +Qed. End PRESERVATION_ASMVLIW. -- cgit From 0b393f7e37315e055eddc5cfba8333639ca265be Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 20 Mar 2019 18:35:03 +0100 Subject: rm tests inherited from Risc-V --- mppa_k1c/Asmexpand.ml | 35 +++++------------------------------ 1 file changed, 5 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1c9e4e4c..f1528389 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -124,9 +124,6 @@ let expand_annot_val kind txt targ args res = assert false (* Handling of memcpy *) -let offset_in_range ofs = - let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L - let emit_move dst r = if dst <> r then emit (Paddil(dst, r, Z.zero));; @@ -175,7 +172,7 @@ let expand_builtin_memcpy sz al args = | _ -> assert false;; (* Handling of volatile reads and writes *) - +(* FIXME probably need to check for size of displacement *) let expand_builtin_vload_common chunk base ofs res = match chunk, res with | Mint8unsigned, BR(Asmblock.IR res) -> @@ -211,21 +208,9 @@ let expand_builtin_vload chunk args res = | [BA(Asmblock.IR addr)] -> expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> - if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk stack_pointer ofs res - else begin - assert false (* FIXME - expand_addptrofs Asmblock.GPR32 stack_pointer ofs; (* X31 <- sp + ofs *) - expand_builtin_vload_common chunk GPR32 _0 res *) - end + expand_builtin_vload_common chunk stack_pointer ofs res | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs))] -> - if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk addr ofs res - else begin - assert false (* FIXME - expand_addptrofs Asmblock.GPR32 addr ofs; (* X31 <- addr + ofs *) - expand_builtin_vload_common chunk Asmblock.GPR32 _0 res *) - end + expand_builtin_vload_common chunk addr ofs res | _ -> assert false @@ -256,19 +241,9 @@ let expand_builtin_vstore chunk args = | [BA(Asmblock.IR addr); src] -> expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> - if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vstore_common chunk stack_pointer ofs src - else begin (* FIXME - expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) - expand_builtin_vstore_common chunk X31 _0 src *) - end + expand_builtin_vstore_common chunk stack_pointer ofs src | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs)); src] -> - if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vstore_common chunk addr ofs src - else begin (* FIXME - expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) - expand_builtin_vstore_common chunk X31 _0 src *) - end + expand_builtin_vstore_common chunk addr ofs src | _ -> assert false -- cgit From 4d5b986ff72098466b3a3bb02c20d0ca697243da Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 20 Mar 2019 19:56:42 +0100 Subject: one step further... --- mppa_k1c/PostpassSchedulingproof.v | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 25bdf244..5b3768af 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -680,9 +680,9 @@ Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Lemma transf_blocks_checks_all_bundles lbb bundles: - transf_blocks (lbb : list bblock) = OK bundles -> - List.Forall (fun bb => verify_par_bblock bb = OK tt) bundles. +Lemma transf_blocks_checks_all_bundles ofs lbb lb bundle: + transf_blocks lbb = OK lb -> + find_bblock (Ptrofs.unsigned ofs) lb = Some bundle -> verify_par_bblock bundle = OK tt. Proof. Admitted. @@ -691,9 +691,31 @@ Lemma all_bundles_are_checked b ofs f bundle: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> verify_par_bblock bundle = OK tt. Proof. - unfold match_prog, match_program, match_program_gen in TRANSL. - (* HOW CAN WE PROVE THIS FROM transf_blocks_checks_all_bundles ?? *) -Admitted. + unfold match_prog, match_program in TRANSL. + unfold Genv.find_funct_ptr; simpl; intros X. + destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. + destruct y as [tf0|]; try congruence. + inversion X as [H1]. subst. clear X. + remember (@Gfun fundef unit (Internal f)) as f2. + destruct H as [ctx' f1 f2 H0|]; try congruence. + inversion Heqf2 as [H2]. subst; clear Heqf2. + unfold transf_fundef, transf_partial_fundef in H. + (* TODO: is there any way to simplify these reasonings in the monad ? *) + destruct f1 as [f1|f1]; try congruence. + remember (transf_function f1) as tf1. + destruct tf1 as [f0|]; simpl in *|-; try congruence. + inversion H as [H1]. subst. clear H. + unfold transf_function in Heqtf1. + remember (transl_function f1) as tf0. + destruct tf0 as [f0|]; simpl in *|-; try congruence. + destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks f0))); simpl in *|-; try congruence. + inversion Heqtf1 as [H]. subst; clear Heqtf1. + unfold transl_function in Heqtf0. + remember (transf_blocks (fn_blocks f1)) as olb. + destruct olb as [lb|]; simpl in *|-; try congruence. + inversion Heqtf0 as [H]. subst; clear Heqtf0. simpl. + intros; exploit transf_blocks_checks_all_bundles; eauto. +Qed. Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> -- cgit From 0dcfa3fef12bcf0185b75c089aa811441c2ea83c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 20 Mar 2019 21:06:43 +0100 Subject: yet another step backward --- mppa_k1c/PostpassSchedulingproof.v | 57 ++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 18 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 5b3768af..4cd40716 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -670,6 +670,9 @@ Qed. End PRESERVATION_ASMBLOCK. + + + Require Import Asmvliw List. Section PRESERVATION_ASMVLIW. @@ -679,16 +682,38 @@ Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +Lemma find_bblock_split lb1: forall ofs lb2 bundle, + find_bblock ofs (lb1 ++ lb2) = Some bundle -> + find_bblock ofs lb1 = Some bundle \/ (exists ofs', find_bblock ofs' lb2 = Some bundle). +Proof. + induction lb1; simpl; eauto. + intros ofs lbd2 bundle H. + destruct (zlt ofs 0); eauto. + destruct (zeq ofs 0); eauto. +Qed. -Lemma transf_blocks_checks_all_bundles ofs lbb lb bundle: - transf_blocks lbb = OK lb -> - find_bblock (Ptrofs.unsigned ofs) lb = Some bundle -> verify_par_bblock bundle = OK tt. +Lemma verified_schedule_checks_alls_bundles bb: forall ofs lb bundle, + verified_schedule bb = OK lb -> + find_bblock ofs lb = Some bundle -> + verify_par_bblock bundle = OK tt. Proof. Admitted. +Lemma transf_blocks_checks_all_bundles lbb: forall ofs lb bundle, + transf_blocks lbb = OK lb -> + find_bblock ofs lb = Some bundle -> verify_par_bblock bundle = OK tt. +Proof. + induction lbb; simpl. + - intros ofs lb bundle H; inversion_clear H. simpl; try congruence. + - intros ofs lb bundle H0. + monadInv H0. + intros H; destruct (find_bblock_split _ _ _ _ H) as [|(ofs' & Hofs')]; eauto. + eapply verified_schedule_checks_alls_bundles; eauto. +Qed. + Lemma all_bundles_are_checked b ofs f bundle: Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + find_bblock ofs (fn_blocks f) = Some bundle -> verify_par_bblock bundle = OK tt. Proof. unfold match_prog, match_program in TRANSL. @@ -700,21 +725,14 @@ Proof. destruct H as [ctx' f1 f2 H0|]; try congruence. inversion Heqf2 as [H2]. subst; clear Heqf2. unfold transf_fundef, transf_partial_fundef in H. - (* TODO: is there any way to simplify these reasonings in the monad ? *) destruct f1 as [f1|f1]; try congruence. - remember (transf_function f1) as tf1. - destruct tf1 as [f0|]; simpl in *|-; try congruence. - inversion H as [H1]. subst. clear H. - unfold transf_function in Heqtf1. - remember (transl_function f1) as tf0. - destruct tf0 as [f0|]; simpl in *|-; try congruence. - destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks f0))); simpl in *|-; try congruence. - inversion Heqtf1 as [H]. subst; clear Heqtf1. - unfold transl_function in Heqtf0. - remember (transf_blocks (fn_blocks f1)) as olb. - destruct olb as [lb|]; simpl in *|-; try congruence. - inversion Heqtf0 as [H]. subst; clear Heqtf0. simpl. - intros; exploit transf_blocks_checks_all_bundles; eauto. + monadInv H. unfold transf_function in EQ. + monadInv EQ. + destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. + injection EQ1; intros; subst. + unfold transl_function in EQ0. + monadInv EQ0. simpl in * |-. + exploit transf_blocks_checks_all_bundles; eauto. Qed. Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: @@ -762,6 +780,9 @@ Qed. End PRESERVATION_ASMVLIW. + + + Section PRESERVATION. Variables prog tprog: program. -- cgit From ad69926edbee2832242d0b991a654cbda66ff367 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 21 Mar 2019 07:10:14 +0100 Subject: simplification of the proof --- mppa_k1c/PostpassScheduling.v | 7 +-- mppa_k1c/PostpassSchedulingproof.v | 92 +++++++++++++++++++++++++++----------- 2 files changed, 70 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index b5d55ad3..8cc74eda 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -351,8 +351,9 @@ Definition verified_schedule_nob (bb : bblock) : res (list bblock) := do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; - do parcheck <- verify_par lbb; - stick_header_code (header bb) lbb. + do res <- stick_header_code (header bb) lbb; + do parcheck <- verify_par res; + OK res. Lemma verified_schedule_nob_size: forall bb lbb, verified_schedule_nob bb = OK lbb -> size bb = size_blocks lbb. @@ -378,7 +379,7 @@ Lemma verified_schedule_nob_header: /\ Forall (fun b => header b = nil) lbb. Proof. intros. split. - - monadInv H. unfold stick_header_code in EQ4. destruct (hd_error _); try discriminate. inv EQ4. + - monadInv H. unfold stick_header_code in EQ2. destruct (hd_error _); try discriminate. inv EQ2. simpl. reflexivity. - apply verified_schedule_nob_no_header_in_middle in H. assumption. Qed. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 4cd40716..1fc5c506 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -673,44 +673,84 @@ End PRESERVATION_ASMBLOCK. -Require Import Asmvliw List. +Require Import Asmvliw. -Section PRESERVATION_ASMVLIW. -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. +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. +Proof. + induction lb; simpl; try tauto. + intros bundle H; monadInv H. + destruct 1; subst; eauto. + destruct x0; auto. +Qed. -Lemma find_bblock_split lb1: forall ofs lb2 bundle, - find_bblock ofs (lb1 ++ lb2) = Some bundle -> - find_bblock ofs lb1 = Some bundle \/ (exists ofs', find_bblock ofs' lb2 = Some bundle). + +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. - induction lb1; simpl; eauto. - intros ofs lbd2 bundle H. - destruct (zlt ofs 0); eauto. - destruct (zeq ofs 0); eauto. + unfold verified_schedule_nob. intros H; + monadInv H. destruct x3. + intros; eapply verified_par_checks_alls_bundles; eauto. +Qed. + +Lemma verify_par_bblock_PExpand bb i: + exit bb = Some (PExpand i) -> verify_par_bblock bb = OK tt. +Proof. + destruct bb as [h bdy ext H]; simpl. + intros; subst. destruct i. + generalize H. + rewrite <- AB.wf_bblock_refl in H. + destruct H as [H H0]. + unfold AB.builtin_alone in H0. erewrite H0; eauto. Qed. -Lemma verified_schedule_checks_alls_bundles bb: forall ofs lb bundle, +Local Hint Resolve verified_schedule_nob_checks_alls_bundles. + +Lemma verified_schedule_checks_alls_bundles bb lb bundle: verified_schedule bb = OK lb -> - find_bblock ofs lb = Some bundle -> - verify_par_bblock bundle = OK tt. + List.In bundle lb -> verify_par_bblock bundle = OK tt. Proof. -Admitted. + unfold verified_schedule. remember (exit bb) as exb. + destruct exb as [c|]; eauto. + destruct c as [i|]; eauto. + destruct i; intros H. inversion_clear H; simpl. + intuition subst. + intros; eapply verify_par_bblock_PExpand; eauto. +Qed. -Lemma transf_blocks_checks_all_bundles lbb: forall ofs lb bundle, +Lemma transf_blocks_checks_all_bundles lbb: forall lb bundle, transf_blocks lbb = OK lb -> - find_bblock ofs lb = Some bundle -> verify_par_bblock bundle = OK tt. + List.In bundle lb -> verify_par_bblock bundle = OK tt. Proof. induction lbb; simpl. - - intros ofs lb bundle H; inversion_clear H. simpl; try congruence. - - intros ofs lb bundle H0. + - intros lb bundle H; inversion_clear H. simpl; try tauto. + - intros lb bundle H0. monadInv H0. - intros H; destruct (find_bblock_split _ _ _ _ H) as [|(ofs' & Hofs')]; eauto. + rewrite in_app. destruct 1; eauto. eapply verified_schedule_checks_alls_bundles; eauto. Qed. +Lemma find_bblock_forall_inv lb P: + (forall b, List.In b lb -> P b) -> + forall ofs b, find_bblock ofs lb = Some b -> P b. +Proof. + induction lb; simpl; try congruence. + intros H ofs b. + destruct (zlt ofs 0); try congruence. + destruct (zeq ofs 0); eauto. + intros X; inversion X; eauto. +Qed. + +Section PRESERVATION_ASMVLIW. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + Lemma all_bundles_are_checked b ofs f bundle: Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> find_bblock ofs (fn_blocks f) = Some bundle -> @@ -726,13 +766,13 @@ Proof. inversion Heqf2 as [H2]. subst; clear Heqf2. unfold transf_fundef, transf_partial_fundef in H. destruct f1 as [f1|f1]; try congruence. - monadInv H. unfold transf_function in EQ. - monadInv EQ. + unfold transf_function, transl_function in H. + monadInv H. monadInv EQ. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. injection EQ1; intros; subst. - unfold transl_function in EQ0. monadInv EQ0. simpl in * |-. - exploit transf_blocks_checks_all_bundles; eauto. + intros; pattern bundle; eapply find_bblock_forall_inv; eauto. + intros; exploit transf_blocks_checks_all_bundles; eauto. Qed. Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: -- cgit From 517ab0d855c46d239798b8441bb4fdb985612f7a Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 21 Mar 2019 17:51:00 +0100 Subject: c --- mppa_k1c/Machblockgenproof.v | 76 ++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 73 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index d7a5ed7d..544f7f52 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -270,6 +270,22 @@ Qed. Axiom TODO: False. (* A ELIMINER *) +Lemma find_label_is_end_block_is_label i l c bl: + is_end_block (trans_inst i) bl -> + is_trans_code c bl -> + i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. +Admitted. + + +(* +Lemma find_label_is_end_block_is_label2 i bl: + forall bl', + (exists l, i=Mlabel l) -> + bl = add_to_new_bblock (trans_inst i) :: bl' -> + bl' = nil. +Admitted. + *) + Lemma find_label_transcode_preserved: forall l c c', Mach.find_label l c = Some c' -> @@ -277,9 +293,63 @@ Lemma find_label_transcode_preserved: Proof. intros l c. remember (trans_code _) as bl. rewrite <- is_trans_code_inv in * |-. - induction Heqbl; - elim TODO. (* A FAIRE *) -Qed. + induction Heqbl. + + intros. + exists (l::nil). + split. + apply in_eq. + simpl. + discriminate. + + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. simpl. + unfold add_label, is_label; simpl. + destruct (in_dec l (l::nil)) as [H0|H0]. + * inversion H as [mbi H1 H2| | ]. + subst bl. + inversion Heqbl. + subst c. simpl. eauto. + * destruct H0. simpl; auto. + - exploit IHHeqbl; eauto. + destruct 1 as (h & H3 & H4). + exists h. + split; auto. + rewrite (find_label_is_end_block_is_label i l c bl);auto. + + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. simpl. + inversion H0 as [H1]. + clear H0. + unfold add_label, is_label; simpl. + apply is_trans_code_inv in Heqbl. + rewrite <- Heqbl. + destruct (in_dec l (l :: header bh)) as [H0|H0]. + * unfold concat. + exists (l :: nil). + split; simpl; eauto. + * destruct H0. simpl; eauto. + - exploit IHHeqbl; eauto. + destruct 1 as (h & H3 & H4). + simpl. + destruct (is_label l (add_label l0 bh)) eqn:H5. + (* + exists (l0::h). + ...*) + (* exists (l0::h). + split; simpl; eauto. + cut (is_label l bh = true). intros. + unfold find_label in H4. rewrite H1 in H4. + unfold add_label, concat; simpl. + destruct (trans_code c'). *) + + (* + exists h. + ...*) + +Admitted. + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? induction c, (trans_code c) using trans_code_ind. -- cgit From 47a4ccade6f73e95be34cd2d55be3655302fff97 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 21 Mar 2019 20:29:57 +0100 Subject: begin jumptables (does not work) --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 11 +++++++++++ mppa_k1c/Asmblockdeps.v | 42 +++++++++++++++++++++++++++++++++++++++++- mppa_k1c/Asmblockgen.v | 5 +++-- 4 files changed, 57 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 493f4a05..8c918c2d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -69,6 +69,7 @@ Inductive instruction : Type := | 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) | Ploopdo (count: ireg) (loopend: label) (** Loads **) @@ -228,6 +229,7 @@ Definition control_to_instruction (c: control) := | PCtlFlow (Asmblock.Pj_l l) => Pj_l l | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l | PCtlFlow (Asmblock.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmblock.Pjumptable r label) => Pjumptable r label end. Definition basic_to_instruction (b: basic) := diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index d335801e..dfe46e04 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -233,6 +233,7 @@ Inductive cf_instruction : Type := | Pret (**r return *) | Pcall (l: label) (**r function call *) | Picall (r: ireg) (**r function call on register value *) + | Pjumptable (r: ireg) (labels: list label) (**r N-way branch through a jump table (pseudo) *) (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) | Pgoto (l: label) (**r goto *) @@ -1470,6 +1471,16 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) Next (rs#PC <- (rs#r)) m | Pj_l l => goto_label f l rs m + | Pjumptable r tbl => + match rs#r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => goto_label f lbl (rs #GPR62 <- Vundef #GPR63 <- Vundef) m + end + | _ => Stuck + end + | Pcb bt r l => match cmp_for_btest bt with | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs#r (Vint (Int.repr 0))) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 501ec212..8c799927 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -42,6 +42,7 @@ Inductive control_op := | Odivu | OError | OIncremPC (sz: Z) + | Ojumptable (l: list label) . Inductive arith_op := @@ -180,6 +181,15 @@ Definition eval_branch_deps (f: function) (l: label) (vpc: val) (res: option boo Definition control_eval (o: control_op) (l: list value) := let (ge, fn) := Ge in match o, l with + | (Ojumptable tbl), [Val index; Val vpc] => + match index with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => None + | Some lbl => goto_label_deps fn lbl vpc + end + | _ => None + end | Oj_l l, [Val vpc] => goto_label_deps fn l vpc | Ocb bt l, [Val v; Val vpc] => match cmp_for_btest bt with @@ -540,6 +550,7 @@ Definition trans_control (ctl: control) : macro := | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] + | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (Name (#r) @ Name (#PC) @ Enil)) ] | Pdiv => [(#GPR0, Op (Control Odiv) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pdivu => [(#GPR0, Op (Control Odivu) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] @@ -879,8 +890,37 @@ Proof. Simpl. * Simpl. * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. + (* Pjumptable *) + + unfold goto_label in *. + destruct (nextblock b rs r) eqn:NB_r in *; try discriminate. + destruct (list_nth_z _ _) eqn:LI in *; try discriminate. + destruct (label_pos _ _ _) eqn:LPOS in *; try discriminate. + rewrite Pregmap.gso in H0; try discriminate. + rewrite Pregmap.gso in H0; try discriminate. + eexists; split; try split. + * simpl control_eval. + rewrite (H3 PC). + simpl. + unfold goto_label_deps. + Simpl. + rewrite H3. + destruct (rs r); try discriminate. + ++ + destruct (nextblock b rs PC) eqn:NB_PC in *; try discriminate. + inv H0. + + destruct (s (# PC)) eqn:sPC in *; try discriminate. + rewrite Pregmap.gso; try discriminate. + destruct (nextblock b rs r) eqn:NB_r in *; try discriminate. + destruct (list_nth_z _ _) eqn:LI in *; try discriminate. + destruct (label_pos _ _ _) eqn:LPOS in *; try discriminate. + destruct (nextblock b rs PC) eqn:NB_PC in *; try discriminate. + inv H1; try discriminate. + assumption. (* Pj_l *) - + unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. + + unfold goto_label in H0. + destruct (label_pos _ _ _) eqn:LPOS; try discriminate. + destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. eexists; split; try split. * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5b00a64f..f3b4b921 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -911,8 +911,9 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co | MBreturn => OK (make_epilogue f (Pret ::g nil)) (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) - | MBjumptable _ _ => - Error (msg "Asmblockgen.transl_instr_control MBjumptable") + | MBjumptable arg tbl => + do r <- ireg_of arg; + OK (Pjumptable r tbl ::g nil) end end. -- cgit From 23fa2a18e015b9d330ad6f1f08cf50adf90bd80b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 21 Mar 2019 22:39:27 +0100 Subject: try to be portable across archs --- mppa_k1c/Machregsaux.ml | 5 +++++ mppa_k1c/Machregsaux.mli | 2 ++ 2 files changed, 7 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregsaux.ml b/mppa_k1c/Machregsaux.ml index 473e0602..9c4175ed 100644 --- a/mppa_k1c/Machregsaux.ml +++ b/mppa_k1c/Machregsaux.ml @@ -31,3 +31,8 @@ let register_by_name s = Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) let can_reserve_register r = Conventions1.is_callee_save r + +let class_of_type = function + | AST.Tint | AST.Tlong + | AST.Tfloat | AST.Tsingle -> 0 + | AST.Tany32 | AST.Tany64 -> assert false diff --git a/mppa_k1c/Machregsaux.mli b/mppa_k1c/Machregsaux.mli index 9404568d..d7117c21 100644 --- a/mppa_k1c/Machregsaux.mli +++ b/mppa_k1c/Machregsaux.mli @@ -16,3 +16,5 @@ val name_of_register: Machregs.mreg -> string option val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool val can_reserve_register: Machregs.mreg -> bool + +val class_of_type: AST.typ -> int -- cgit From 49ea6f7d4b9e18f8aa740d068bb3fb9e49596e00 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 00:28:46 +0100 Subject: I think it should now compile for all architectures. --- mppa_k1c/ConstpropOp.v | 613 ------------------------------------------------- 1 file changed, 613 deletions(-) delete mode 100644 mppa_k1c/ConstpropOp.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/ConstpropOp.v b/mppa_k1c/ConstpropOp.v deleted file mode 100644 index e7391ab5..00000000 --- a/mppa_k1c/ConstpropOp.v +++ /dev/null @@ -1,613 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Strength reduction for operators and conditions. - This is the machine-dependent part of [Constprop]. *) - -Require Archi. -Require Import Coqlib Compopts. -Require Import AST Integers Floats. -Require Import Op Registers. -Require Import ValueDomain. - -(** * Converting known values to constants *) - -Definition const_for_result (a: aval) : option operation := - match a with - | I n => Some(Ointconst n) - | L n => if Archi.ptr64 then Some(Olongconst n) else None - | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None - | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None - | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) - | Ptr(Stk ofs) => Some(Oaddrstack ofs) - | _ => None - end. - -(** * Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -(** Original definition: -<< -Nondetfunction cond_strength_reduction - (cond: condition) (args: list reg) (vl: list aval) := - match cond, args, vl with - | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompimm (swap_comparison c) n1, r2 :: nil) - | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompimm c n2, r1 :: nil) - | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompuimm (swap_comparison c) n1, r2 :: nil) - | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompuimm c n2, r1 :: nil) - | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccomplimm (swap_comparison c) n1, r2 :: nil) - | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccomplimm c n2, r1 :: nil) - | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccompluimm (swap_comparison c) n1, r2 :: nil) - | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccompluimm c n2, r1 :: nil) - | _, _, _ => - (cond, args) - end. ->> -*) - -Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list aval), Type := - | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | cond_strength_reduction_case5: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | cond_strength_reduction_case6: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | cond_strength_reduction_case7: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | cond_strength_reduction_case8: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list aval), cond_strength_reduction_cases cond args vl. - -Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list aval) := - match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with - | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 - | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 - | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 - | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 - | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case5 c r1 r2 n1 v2 - | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case6 c r1 r2 v1 n2 - | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case7 c r1 r2 n1 v2 - | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case8 c r1 r2 v1 n2 - | cond, args, vl => cond_strength_reduction_default cond args vl - end. - -Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list aval) := - match cond_strength_reduction_match cond args vl with - | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - (Ccompimm (swap_comparison c) n1, r2 :: nil) - | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - (Ccompimm c n2, r1 :: nil) - | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - (Ccompuimm (swap_comparison c) n1, r2 :: nil) - | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - (Ccompuimm c n2, r1 :: nil) - | cond_strength_reduction_case5 c r1 r2 n1 v2 => (* Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - (Ccomplimm (swap_comparison c) n1, r2 :: nil) - | cond_strength_reduction_case6 c r1 r2 v1 n2 => (* Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - (Ccomplimm c n2, r1 :: nil) - | cond_strength_reduction_case7 c r1 r2 n1 v2 => (* Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - (Ccompluimm (swap_comparison c) n1, r2 :: nil) - | cond_strength_reduction_case8 c r1 r2 v1 n2 => (* Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - (Ccompluimm c n2, r1 :: nil) - | cond_strength_reduction_default cond args vl => - (cond, args) - end. - - -Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := - let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). - -Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) - (n: int) (r1: reg) (v1: aval) := - if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl. - -Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) - (n: int) (r1: reg) (v1: aval) := - if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl. - -(** Original definition: -<< -Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := - match c, args, vl with - | Ccompimm Ceq n, r1 :: nil, v1 :: nil => - make_cmp_imm_eq c args vl n r1 v1 - | Ccompimm Cne n, r1 :: nil, v1 :: nil => - make_cmp_imm_ne c args vl n r1 v1 - | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => - make_cmp_imm_eq c args vl n r1 v1 - | Ccompuimm Cne n, r1 :: nil, v1 :: nil => - make_cmp_imm_ne c args vl n r1 v1 - | _, _, _ => - make_cmp_base c args vl - end. ->> -*) - -Inductive make_cmp_cases: forall (c: condition) (args: list reg) (vl: list aval), Type := - | make_cmp_case1: forall n r1 v1, make_cmp_cases (Ccompimm Ceq n) (r1 :: nil) (v1 :: nil) - | make_cmp_case2: forall n r1 v1, make_cmp_cases (Ccompimm Cne n) (r1 :: nil) (v1 :: nil) - | make_cmp_case3: forall n r1 v1, make_cmp_cases (Ccompuimm Ceq n) (r1 :: nil) (v1 :: nil) - | make_cmp_case4: forall n r1 v1, make_cmp_cases (Ccompuimm Cne n) (r1 :: nil) (v1 :: nil) - | make_cmp_default: forall (c: condition) (args: list reg) (vl: list aval), make_cmp_cases c args vl. - -Definition make_cmp_match (c: condition) (args: list reg) (vl: list aval) := - match c as zz1, args as zz2, vl as zz3 return make_cmp_cases zz1 zz2 zz3 with - | Ccompimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case1 n r1 v1 - | Ccompimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case2 n r1 v1 - | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case3 n r1 v1 - | Ccompuimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case4 n r1 v1 - | c, args, vl => make_cmp_default c args vl - end. - -Definition make_cmp (c: condition) (args: list reg) (vl: list aval) := - match make_cmp_match c args vl with - | make_cmp_case1 n r1 v1 => (* Ccompimm Ceq n, r1 :: nil, v1 :: nil *) - make_cmp_imm_eq c args vl n r1 v1 - | make_cmp_case2 n r1 v1 => (* Ccompimm Cne n, r1 :: nil, v1 :: nil *) - make_cmp_imm_ne c args vl n r1 v1 - | make_cmp_case3 n r1 v1 => (* Ccompuimm Ceq n, r1 :: nil, v1 :: nil *) - make_cmp_imm_eq c args vl n r1 v1 - | make_cmp_case4 n r1 v1 => (* Ccompuimm Cne n, r1 :: nil, v1 :: nil *) - make_cmp_imm_ne c args vl n r1 v1 - | make_cmp_default c args vl => - make_cmp_base c args vl - end. - - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oaddimm n, r :: nil). - -Definition make_shlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) - else (Oshl, r1 :: r2 :: nil). - -Definition make_shrimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) - else (Oshr, r1 :: r2 :: nil). - -Definition make_shruimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) - else (Oshru, r1 :: r2 :: nil). - -Definition make_mulimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => (Oshlimm l, r1 :: nil) - | None => (Omul, r1 :: r2 :: nil) - end. - -Definition make_andimm (n: int) (r: reg) (a: aval) := - if Int.eq n Int.zero then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero - | _ => false end - then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else (Oxorimm n, r :: nil). - -Definition make_divimm n (r1 r2: reg) := - if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (Odiv, r1 :: r2 :: nil) - | None => (Odiv, r1 :: r2 :: nil) - end. - -Definition make_divuimm n (r1 r2: reg) := - if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => (Oshruimm l, r1 :: nil) - | None => (Odivu, r1 :: r2 :: nil) - end. - -Definition make_moduimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (Omodu, r1 :: r2 :: nil) - end. - -Definition make_addlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero - then (Omove, r :: nil) - else (Oaddlimm n, r :: nil). - -Definition make_shllimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) - else (Oshll, r1 :: r2 :: nil). - -Definition make_shrlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) - else (Oshrl, r1 :: r2 :: nil). - -Definition make_shrluimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) - else (Oshrlu, r1 :: r2 :: nil). - -Definition make_mullimm (n: int64) (r1 r2: reg) := - if Int64.eq n Int64.zero then - (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.one then - (Omove, r1 :: nil) - else - match Int64.is_power2' n with - | Some l => (Oshllimm l, r1 :: nil) - | None => (Omull, r1 :: r2 :: nil) - end. - -Definition make_andlimm (n: int64) (r: reg) (a: aval) := - if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.mone then (Omove, r :: nil) - else (Oandlimm n, r :: nil). - -Definition make_orlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) - else (Oorlimm n, r :: nil). - -Definition make_xorlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else (Oxorlimm n, r :: nil). - -Definition make_divlimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => if Int.ltu l (Int.repr 63) - then (Oshrxlimm l, r1 :: nil) - else (Odivl, r1 :: r2 :: nil) - | None => (Odivl, r1 :: r2 :: nil) - end. - -Definition make_divluimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => (Oshrluimm l, r1 :: nil) - | None => (Odivlu, r1 :: r2 :: nil) - end. - -Definition make_modluimm n (r1 r2: reg) := - match Int64.is_power2 n with - | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) - | None => (Omodlu, r1 :: r2 :: nil) - end. - -Definition make_mulfimm (n: float) (r r1 r2: reg) := - if Float.eq_dec n (Float.of_int (Int.repr 2)) - then (Oaddf, r :: r :: nil) - else (Omulf, r1 :: r2 :: nil). - -Definition make_mulfsimm (n: float32) (r r1 r2: reg) := - if Float32.eq_dec n (Float32.of_int (Int.repr 2)) - then (Oaddfs, r :: r :: nil) - else (Omulfs, r1 :: r2 :: nil). - -Definition make_cast8signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). -Definition make_cast16signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). - -(** Original definition: -<< -Nondetfunction op_strength_reduction - (op: operation) (args: list reg) (vl: list aval) := - match op, args, vl with - | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 - | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 - | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 - | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 - | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 - | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 - | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 - | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 - | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 - | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 - | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 - | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 - | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 - | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 - | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 - | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 - | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 - | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 - | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 - | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 - | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 - | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 - | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 - | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 - | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 - | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 - | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 - | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 - | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 - | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 - | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 - | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 - | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 - | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 - | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 - | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 - | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 - | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 - | Ocmp c, args, vl => make_cmp c args vl - | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 - | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 - | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 - | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 - | _, _, _ => (op, args) - end. ->> -*) - -Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list aval), Type := - | op_strength_reduction_case1: forall r1 v1, op_strength_reduction_cases (Ocast8signed) (r1 :: nil) (v1 :: nil) - | op_strength_reduction_case2: forall r1 v1, op_strength_reduction_cases (Ocast16signed) (r1 :: nil) (v1 :: nil) - | op_strength_reduction_case3: forall r1 r2 n1 v2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | op_strength_reduction_case4: forall r1 r2 v1 n2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case6: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case11: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | op_strength_reduction_case12: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case13: forall n r1 v1, op_strength_reduction_cases (Oandimm n) (r1 :: nil) (v1 :: nil) - | op_strength_reduction_case14: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | op_strength_reduction_case15: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case16: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) - | op_strength_reduction_case17: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case18: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case20: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case21: forall r1 r2 n1 v2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | op_strength_reduction_case22: forall r1 r2 v1 n2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case23: forall r1 r2 v1 n2, op_strength_reduction_cases (Osubl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case24: forall r1 r2 n1 v2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case26: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case27: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case28: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case29: forall r1 r2 n1 v2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | op_strength_reduction_case30: forall r1 r2 v1 n2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case31: forall n r1 v1, op_strength_reduction_cases (Oandlimm n) (r1 :: nil) (v1 :: nil) - | op_strength_reduction_case32: forall r1 r2 n1 v2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | op_strength_reduction_case33: forall r1 r2 v1 n2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case34: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) - | op_strength_reduction_case35: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) - | op_strength_reduction_case36: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshll) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case37: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case38: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrlu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) - | op_strength_reduction_case39: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) - | op_strength_reduction_case40: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (v1 :: F n2 :: nil) - | op_strength_reduction_case41: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (F n1 :: v2 :: nil) - | op_strength_reduction_case42: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (v1 :: FS n2 :: nil) - | op_strength_reduction_case43: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (FS n1 :: v2 :: nil) - | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list aval), op_strength_reduction_cases op args vl. - -Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list aval) := - match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with - | Ocast8signed, r1 :: nil, v1 :: nil => op_strength_reduction_case1 r1 v1 - | Ocast16signed, r1 :: nil, v1 :: nil => op_strength_reduction_case2 r1 v1 - | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case3 r1 r2 n1 v2 - | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case4 r1 r2 v1 n2 - | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 - | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case6 r1 r2 n1 v2 - | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 - | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 - | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 - | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 - | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case11 r1 r2 n1 v2 - | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case12 r1 r2 v1 n2 - | Oandimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case13 n r1 v1 - | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case14 r1 r2 n1 v2 - | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case15 r1 r2 v1 n2 - | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case16 r1 r2 n1 v2 - | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 r1 r2 v1 n2 - | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case18 r1 r2 v1 n2 - | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2 - | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 r1 r2 v1 n2 - | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case21 r1 r2 n1 v2 - | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case22 r1 r2 v1 n2 - | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case23 r1 r2 v1 n2 - | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case24 r1 r2 n1 v2 - | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2 - | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case26 r1 r2 v1 n2 - | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case27 r1 r2 v1 n2 - | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case28 r1 r2 v1 n2 - | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case29 r1 r2 n1 v2 - | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case30 r1 r2 v1 n2 - | Oandlimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case31 n r1 v1 - | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case32 r1 r2 n1 v2 - | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case33 r1 r2 v1 n2 - | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case34 r1 r2 n1 v2 - | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case35 r1 r2 v1 n2 - | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case36 r1 r2 v1 n2 - | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case37 r1 r2 v1 n2 - | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case38 r1 r2 v1 n2 - | Ocmp c, args, vl => op_strength_reduction_case39 c args vl - | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => op_strength_reduction_case40 r1 r2 v1 n2 - | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => op_strength_reduction_case41 r1 r2 n1 v2 - | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => op_strength_reduction_case42 r1 r2 v1 n2 - | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => op_strength_reduction_case43 r1 r2 n1 v2 - | op, args, vl => op_strength_reduction_default op args vl - end. - -Definition op_strength_reduction (op: operation) (args: list reg) (vl: list aval) := - match op_strength_reduction_match op args vl with - | op_strength_reduction_case1 r1 v1 => (* Ocast8signed, r1 :: nil, v1 :: nil *) - make_cast8signed r1 v1 - | op_strength_reduction_case2 r1 v1 => (* Ocast16signed, r1 :: nil, v1 :: nil *) - make_cast16signed r1 v1 - | op_strength_reduction_case3 r1 r2 n1 v2 => (* Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - make_addimm n1 r2 - | op_strength_reduction_case4 r1 r2 v1 n2 => (* Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_addimm n2 r1 - | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_addimm (Int.neg n2) r1 - | op_strength_reduction_case6 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - make_mulimm n1 r2 r1 - | op_strength_reduction_case7 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_mulimm n2 r1 r2 - | op_strength_reduction_case8 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_divimm n2 r1 r2 - | op_strength_reduction_case9 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_divuimm n2 r1 r2 - | op_strength_reduction_case10 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_moduimm n2 r1 r2 - | op_strength_reduction_case11 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - make_andimm n1 r2 v2 - | op_strength_reduction_case12 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_andimm n2 r1 v1 - | op_strength_reduction_case13 n r1 v1 => (* Oandimm n, r1 :: nil, v1 :: nil *) - make_andimm n r1 v1 - | op_strength_reduction_case14 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - make_orimm n1 r2 - | op_strength_reduction_case15 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_orimm n2 r1 - | op_strength_reduction_case16 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) - make_xorimm n1 r2 - | op_strength_reduction_case17 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_xorimm n2 r1 - | op_strength_reduction_case18 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shlimm n2 r1 r2 - | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shrimm n2 r1 r2 - | op_strength_reduction_case20 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shruimm n2 r1 r2 - | op_strength_reduction_case21 r1 r2 n1 v2 => (* Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - make_addlimm n1 r2 - | op_strength_reduction_case22 r1 r2 v1 n2 => (* Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_addlimm n2 r1 - | op_strength_reduction_case23 r1 r2 v1 n2 => (* Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_addlimm (Int64.neg n2) r1 - | op_strength_reduction_case24 r1 r2 n1 v2 => (* Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - make_mullimm n1 r2 r1 - | op_strength_reduction_case25 r1 r2 v1 n2 => (* Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_mullimm n2 r1 r2 - | op_strength_reduction_case26 r1 r2 v1 n2 => (* Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_divlimm n2 r1 r2 - | op_strength_reduction_case27 r1 r2 v1 n2 => (* Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_divluimm n2 r1 r2 - | op_strength_reduction_case28 r1 r2 v1 n2 => (* Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_modluimm n2 r1 r2 - | op_strength_reduction_case29 r1 r2 n1 v2 => (* Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - make_andlimm n1 r2 v2 - | op_strength_reduction_case30 r1 r2 v1 n2 => (* Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_andlimm n2 r1 v1 - | op_strength_reduction_case31 n r1 v1 => (* Oandlimm n, r1 :: nil, v1 :: nil *) - make_andlimm n r1 v1 - | op_strength_reduction_case32 r1 r2 n1 v2 => (* Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - make_orlimm n1 r2 - | op_strength_reduction_case33 r1 r2 v1 n2 => (* Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_orlimm n2 r1 - | op_strength_reduction_case34 r1 r2 n1 v2 => (* Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) - make_xorlimm n1 r2 - | op_strength_reduction_case35 r1 r2 v1 n2 => (* Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) - make_xorlimm n2 r1 - | op_strength_reduction_case36 r1 r2 v1 n2 => (* Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shllimm n2 r1 r2 - | op_strength_reduction_case37 r1 r2 v1 n2 => (* Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shrlimm n2 r1 r2 - | op_strength_reduction_case38 r1 r2 v1 n2 => (* Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) - make_shrluimm n2 r1 r2 - | op_strength_reduction_case39 c args vl => (* Ocmp c, args, vl *) - make_cmp c args vl - | op_strength_reduction_case40 r1 r2 v1 n2 => (* Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil *) - make_mulfimm n2 r1 r1 r2 - | op_strength_reduction_case41 r1 r2 n1 v2 => (* Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil *) - make_mulfimm n1 r2 r1 r2 - | op_strength_reduction_case42 r1 r2 v1 n2 => (* Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil *) - make_mulfsimm n2 r1 r1 r2 - | op_strength_reduction_case43 r1 r2 n1 v2 => (* Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil *) - make_mulfsimm n1 r2 r1 r2 - | op_strength_reduction_default op args vl => - (op, args) - end. - - -(** Original definition: -<< -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 Archi.pic_code tt - then (addr, args) - else (Aglobal symb (Ptrofs.add n1 n), nil) - | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => - (Ainstack (Ptrofs.add n1 n), nil) - | _, _, _ => - (addr, args) - end. ->> -*) - -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := - | addr_strength_reduction_case1: forall n r1 symb n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Gl symb n1) :: nil) - | addr_strength_reduction_case2: forall n r1 n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Stk n1) :: nil) - | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_cases addr args vl. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list aval) := - match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with - | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => addr_strength_reduction_case1 n r1 symb n1 - | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => addr_strength_reduction_case2 n r1 n1 - | addr, args, vl => addr_strength_reduction_default addr args vl - end. - -Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := - match addr_strength_reduction_match addr args vl with - | addr_strength_reduction_case1 n r1 symb n1 => (* Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil *) - if Archi.pic_code tt then (addr, args) else (Aglobal symb (Ptrofs.add n1 n), nil) - | addr_strength_reduction_case2 n r1 n1 => (* Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil *) - (Ainstack (Ptrofs.add n1 n), nil) - | addr_strength_reduction_default addr args vl => - (addr, args) - end. - - -- cgit From 5a425ba34f3f2520de752ea95a4636a9437c312a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 08:12:41 +0100 Subject: ça recompile sur x86 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/SelectOp.vp | 39 +---------------------------- mppa_k1c/SelectOpproof.v | 65 ------------------------------------------------ 2 files changed, 1 insertion(+), 103 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 19712d2f..f6605c11 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -50,6 +50,7 @@ Require Import Integers. Require Import Floats. Require Import Op. Require Import CminorSel. +Require Import OpHelpers. Local Open Scope cminorsel_scope. @@ -57,44 +58,6 @@ Local Open Scope string_scope. Local Open Scope error_monad_scope. Section SELECT. -(** Some operations on 64-bit integers are transformed into calls to - runtime library functions. The following type class collects - the names of these functions. *) - -Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default. -Definition sig_l_f := mksignature (Tlong :: nil) (Some Tfloat) cc_default. -Definition sig_l_s := mksignature (Tlong :: nil) (Some Tsingle) cc_default. -Definition sig_f_l := mksignature (Tfloat :: nil) (Some Tlong) cc_default. -Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default. -Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default. -Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default. -Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default. -Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default. -Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default. - -Class helper_functions := mk_helper_functions { - i64_dtos: ident; (**r float64 -> signed long *) - i64_dtou: ident; (**r float64 -> unsigned long *) - i64_stod: ident; (**r signed long -> float64 *) - i64_utod: ident; (**r unsigned long -> float64 *) - i64_stof: ident; (**r signed long -> float32 *) - i64_utof: ident; (**r unsigned long -> float32 *) - i64_sdiv: ident; (**r signed division *) - i64_udiv: ident; (**r unsigned division *) - i64_smod: ident; (**r signed remainder *) - i64_umod: ident; (**r unsigned remainder *) - i64_shl: ident; (**r shift left *) - i64_shr: ident; (**r shift right unsigned *) - i64_sar: ident; (**r shift right signed *) - i64_umulh: ident; (**r unsigned multiply high *) - i64_smulh: ident; (**r signed multiply high *) - i32_sdiv: ident; (**r signed division *) - i32_udiv: ident; (**r unsigned division *) - i32_smod: ident; (**r signed remainder *) - i32_umod: ident; (**r unsigned remainder *) - f64_div: ident; (**float division*) - f32_div: ident; (**float division*) -}. Context {hf: helper_functions}. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index a4a5f72b..111c08e4 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -35,71 +35,6 @@ Local Open Scope cminorsel_scope. Local Open Scope string_scope. -(** * Axiomatization of the helper functions *) - -Definition external_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := - forall F V (ge: Genv.t F V) m, - external_call (EF_runtime name sg) ge vargs m E0 vres m. - -Definition builtin_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := - forall F V (ge: Genv.t F V) m, - external_call (EF_builtin name sg) ge vargs m E0 vres m. - -Axiom i64_helpers_correct : - (forall x z, Val.longoffloat x = Some z -> external_implements "__compcert_i64_dtos" sig_f_l (x::nil) z) - /\ (forall x z, Val.longuoffloat x = Some z -> external_implements "__compcert_i64_dtou" sig_f_l (x::nil) z) - /\ (forall x z, Val.floatoflong x = Some z -> external_implements "__compcert_i64_stod" sig_l_f (x::nil) z) - /\ (forall x z, Val.floatoflongu x = Some z -> external_implements "__compcert_i64_utod" sig_l_f (x::nil) z) - /\ (forall x z, Val.singleoflong x = Some z -> external_implements "__compcert_i64_stof" sig_l_s (x::nil) z) - /\ (forall x z, Val.singleoflongu x = Some z -> external_implements "__compcert_i64_utof" sig_l_s (x::nil) z) - /\ (forall x, builtin_implements "__builtin_negl" sig_l_l (x::nil) (Val.negl x)) - /\ (forall x y, builtin_implements "__builtin_addl" sig_ll_l (x::y::nil) (Val.addl x y)) - /\ (forall x y, builtin_implements "__builtin_subl" sig_ll_l (x::y::nil) (Val.subl x y)) - /\ (forall x y, builtin_implements "__builtin_mull" sig_ii_l (x::y::nil) (Val.mull' x y)) - /\ (forall x y z, Val.divls x y = Some z -> external_implements "__compcert_i64_sdiv" sig_ll_l (x::y::nil) z) - /\ (forall x y z, Val.divlu x y = Some z -> external_implements "__compcert_i64_udiv" sig_ll_l (x::y::nil) z) - /\ (forall x y z, Val.modls x y = Some z -> external_implements "__compcert_i64_smod" sig_ll_l (x::y::nil) z) - /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__compcert_i64_umod" sig_ll_l (x::y::nil) z) - /\ (forall x y, external_implements "__compcert_i64_shl" sig_li_l (x::y::nil) (Val.shll x y)) - /\ (forall x y, external_implements "__compcert_i64_shr" sig_li_l (x::y::nil) (Val.shrlu x y)) - /\ (forall x y, external_implements "__compcert_i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)) - /\ (forall x y, external_implements "__compcert_i64_umulh" sig_ll_l (x::y::nil) (Val.mullhu x y)) - /\ (forall x y, external_implements "__compcert_i64_smulh" sig_ll_l (x::y::nil) (Val.mullhs x y)) - /\ (forall x y z, Val.divs x y = Some z -> external_implements "__compcert_i32_sdiv" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.divu x y = Some z -> external_implements "__compcert_i32_udiv" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.mods x y = Some z -> external_implements "__compcert_i32_smod" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.modu x y = Some z -> external_implements "__compcert_i32_umod" sig_ii_i (x::y::nil) z) - /\ (forall x y z, Val.divfs x y = z -> external_implements "__compcert_f32_div" sig_ss_s (x::y::nil) z) - /\ (forall x y z, Val.divf x y = z -> external_implements "__compcert_f64_div" sig_ff_f (x::y::nil) z) -. - -Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := - (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). - -Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := - helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l - /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l - /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f - /\ helper_declared p i64_utod "__compcert_i64_utod" sig_l_f - /\ helper_declared p i64_stof "__compcert_i64_stof" sig_l_s - /\ helper_declared p i64_utof "__compcert_i64_utof" sig_l_s - /\ helper_declared p i64_sdiv "__compcert_i64_sdiv" sig_ll_l - /\ helper_declared p i64_udiv "__compcert_i64_udiv" sig_ll_l - /\ helper_declared p i64_smod "__compcert_i64_smod" sig_ll_l - /\ helper_declared p i64_umod "__compcert_i64_umod" sig_ll_l - /\ helper_declared p i64_shl "__compcert_i64_shl" sig_li_l - /\ helper_declared p i64_shr "__compcert_i64_shr" sig_li_l - /\ helper_declared p i64_sar "__compcert_i64_sar" sig_li_l - /\ helper_declared p i64_umulh "__compcert_i64_umulh" sig_ll_l - /\ helper_declared p i64_smulh "__compcert_i64_smulh" sig_ll_l - /\ helper_declared p i32_sdiv "__compcert_i32_sdiv" sig_ii_i - /\ helper_declared p i32_udiv "__compcert_i32_udiv" sig_ii_i - /\ helper_declared p i32_smod "__compcert_i32_smod" sig_ii_i - /\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i - /\ helper_declared p f32_div "__compcert_f32_div" sig_ss_s - /\ helper_declared p f64_div "__compcert_f64_div" sig_ff_f -. - (** * Useful lemmas and tactics *) (** The following are trivial lemmas and custom tactics that help -- cgit From 1fd8a013a4fa57fcfa6c9e295638871153e596ee Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 09:27:40 +0100 Subject: restructuration pour compilation toute archi --- mppa_k1c/SelectLong.vp | 1 + mppa_k1c/SelectLongproof.v | 1 + mppa_k1c/SelectOpproof.v | 4 +++- 3 files changed, 5 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 3a17ab17..0c3618d7 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -21,6 +21,7 @@ Require Import Coqlib. Require Import Compopts. Require Import AST Integers Floats. Require Import Op CminorSel. +Require Import OpHelpers. Require Import SelectOp SplitLong. Local Open Scope cminorsel_scope. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 4723278a..79187338 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -21,6 +21,7 @@ Require Import String Coqlib Maps Integers Floats Errors. Require Archi. Require Import AST Values Memory Globalenvs Events. Require Import Cminor Op CminorSel. +Require Import OpHelpers OpHelpersproof. Require Import SelectOp SelectOpproof SplitLong SplitLongproof. Require Import SelectLong. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 111c08e4..89af39ee 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -30,6 +30,8 @@ Require Import Op. Require Import CminorSel. Require Import SelectOp. Require Import Events. +Require Import OpHelpers. +Require Import OpHelpersproof. Local Open Scope cminorsel_scope. Local Open Scope string_scope. @@ -93,7 +95,7 @@ Variable m: mem. (* Helper lemmas - from SplitLongproof.v *) -Ltac UseHelper := decompose [Logic.and] i64_helpers_correct; eauto. +Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto. Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. Lemma eval_helper: -- cgit From 1bc0ce716ff90a5384a70b5f9426108bb6380549 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 10:49:09 +0100 Subject: rm Pdiv / Pdivu --- mppa_k1c/Asm.v | 5 ----- mppa_k1c/Asmblock.v | 16 +--------------- mppa_k1c/Asmblockdeps.v | 29 ----------------------------- mppa_k1c/Asmblockgen.v | 12 ------------ mppa_k1c/PostpassSchedulingOracle.ml | 1 - mppa_k1c/TargetPrinter.ml | 4 ---- 6 files changed, 1 insertion(+), 66 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 493f4a05..0ca554ab 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -50,9 +50,6 @@ Inductive instruction : Type := | Psemi (**r semi colon separating bundles *) | Pnop (**r instruction that does nothing *) - | Pdiv (**r 32 bits integer division *) - | Pdivu (**r 32 bits integer division *) - (** builtins *) | Pclzll (rd rs: ireg) | Pstsud (rd rs1 rs2: ireg) @@ -218,8 +215,6 @@ Inductive instruction : Type := Definition control_to_instruction (c: control) := match c with | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res - | PExpand (Asmblock.Pdiv) => Pdiv - | PExpand (Asmblock.Pdivu) => Pdivu | PCtlFlow Asmblock.Pret => Pret | PCtlFlow (Asmblock.Pcall l) => Pcall l | PCtlFlow (Asmblock.Picall r) => Picall r diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index d335801e..fdec8ed2 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -178,10 +178,7 @@ Inductive ex_instruction : Type := | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) - | Pdiv (**r 32 bits integer division, call to __divdi3 *) - | Pdivu (**r 32 bits integer division, call to __udivdi3 *) -. + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *). (** FIXME: comment not up to date ! @@ -1486,17 +1483,6 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) (** Pseudo-instructions *) | Pbuiltin ef args res => Stuck (**r treated specially below *) - | Pdiv => - match Val.divs (rs GPR0) (rs GPR1) with - | Some v => Next (rs # GPR0 <- v # RA <- (rs RA)) m - | None => Stuck - end - - | Pdivu => - match Val.divu (rs GPR0) (rs GPR1) with - | Some v => Next (rs # GPR0 <- v # RA <- (rs RA)) m - | None => Stuck - end end | None => Next rs m end. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 501ec212..ad96ae87 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -540,8 +540,6 @@ Definition trans_control (ctl: control) : macro := | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] - | Pdiv => [(#GPR0, Op (Control Odiv) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] - | Pdivu => [(#GPR0, Op (Control Odivu) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. @@ -863,22 +861,6 @@ Proof. intros. destruct ex. - simpl in *. inv H1. destruct c; destruct i; try discriminate. all: try (inv H0; eexists; split; try split; [ simpl control_eval; pose (H3 PC); simpl in e; rewrite e; reflexivity | Simpl | intros rr; destruct rr; Simpl]). - (* Pdiv *) - + destruct (Val.divs _ _) eqn:DIVS; try discriminate. inv H0. unfold nextblock in DIVS. repeat (rewrite Pregmap.gso in DIVS; try discriminate). - eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e; clear e. simpl. - Simpl. pose (H3 GPR0); rewrite e; clear e. pose (H3 GPR1); rewrite e; clear e. rewrite DIVS. - Simpl. - * Simpl. - * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. - (* Pdivu *) - + destruct (Val.divu _ _) eqn:DIVU; try discriminate. inv H0. unfold nextblock in DIVU. repeat (rewrite Pregmap.gso in DIVU; try discriminate). - eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e; clear e. simpl. - Simpl. pose (H3 GPR0); rewrite e; clear e. pose (H3 GPR1); rewrite e; clear e. rewrite DIVU. - Simpl. - * Simpl. - * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. (* Pj_l *) + unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. eexists; split; try split. @@ -1070,12 +1052,6 @@ Lemma exec_exit_none: Proof. intros. inv H0. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try reflexivity; try discriminate. -(* Pdiv *) - - simpl in *. pose (H3 GPR0); rewrite e in H1; clear e. pose (H3 GPR1); rewrite e in H1; clear e. - destruct (Val.divs _ _); try discriminate; auto. -(* Pdivu *) - - simpl in *. pose (H3 GPR0); rewrite e in H1; clear e. pose (H3 GPR1); rewrite e in H1; clear e. - destruct (Val.divu _ _); try discriminate; auto. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. unfold goto_label_deps in H1. unfold goto_label. @@ -1187,11 +1163,6 @@ Lemma forward_simu_exit_stuck: Proof. intros. inv H1. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). -(* Pdiv *) - - simpl in *. pose (H3 GPR0); simpl in e; rewrite e; clear e. pose (H3 GPR1); simpl in e; rewrite e; clear e. - destruct (Val.divs _ _); try discriminate; auto. - - simpl in *. pose (H3 GPR0); simpl in e; rewrite e; clear e. pose (H3 GPR1); simpl in e; rewrite e; clear e. - destruct (Val.divu _ _); try discriminate; auto. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold goto_label in H0. destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5b00a64f..c03e319c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -425,18 +425,6 @@ Definition transl_op OK (mulimm32 rd rs1 n ::i k) | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") (* Normalement pas émis *) | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (* Normalement pas émis *) - | Odiv, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odiv: 32-bits division not supported yet. Please use 64-bits.") - (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivw rd rs1 rs2 :: k) *) - | Odivu, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Odivu: 32-bits division not supported yet. Please use 64-bits.") - (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pdivuw rd rs1 rs2 :: k) *) - | Omod, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Omod: 32-bits modulo not supported yet. Please use 64-bits.") - (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premw rd rs1 rs2 :: k) *) - | Omodu, a1 :: a2 :: nil => Error(msg "Asmblockgen.transl_op: Omodu: 32-bits modulo not supported yet. Please use 64-bits.") - (* do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Premuw rd rs1 rs2 :: k) *) | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 ::i k) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2c39e342..56b00c7e 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -222,7 +222,6 @@ let basic_rec i = | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false} let expand_rec = function - | Pdiv | Pdivu -> { inst = "Pdiv"; write_locs = [Reg (IR GPR0)]; read_locs = [Reg (IR GPR0); Reg (IR GPR1)]; imm = None; is_control = true } | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d4e2afc9..69824852 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -258,10 +258,6 @@ module Target (*: TARGET*) = fprintf oc " goto %a\n" symbol s | Pigoto(rs) -> fprintf oc " igoto %a\n" ireg rs - | Pdiv -> - fprintf oc " call __divdi3\n" - | Pdivu -> - fprintf oc " call __udivdi3\n" | Pj_l(s) -> fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> -- cgit From 44cfe47f9e5d0c40fad23fccdb4b37b1ea3c1071 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Mar 2019 12:04:43 +0100 Subject: Fixed proof of Asmblockdeps wrt Pjumptable --- mppa_k1c/Asmblockdeps.v | 53 ++++++++++++++++++++++++++----------------------- 1 file changed, 28 insertions(+), 25 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 8c799927..1acc3b58 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -366,6 +366,7 @@ Definition control_op_eq (c1 c2: control_op): ?? bool := | Oj_l l1, Oj_l l2 => phys_eq l1 l2 | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) + | Ojumptable tbl1, Ojumptable tbl2 => phys_eq tbl1 tbl2 | Odiv, Odiv => RET true | Odivu, Odivu => RET true | OIncremPC sz1, OIncremPC sz2 => RET (Z.eqb sz1 sz2) @@ -381,6 +382,7 @@ Proof. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - rewrite Z.eqb_eq in * |-. congruence. + - congruence. Qed. @@ -550,7 +552,9 @@ Definition trans_control (ctl: control) : macro := | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] - | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (Name (#r) @ Name (#PC) @ Enil)) ] + | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (Name (#r) @ Name (#PC) @ Enil)); + (#GPR62, Op (Constant Vundef) Enil); + (#GPR63, Op (Constant Vundef) Enil) ] | Pdiv => [(#GPR0, Op (Control Odiv) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pdivu => [(#GPR0, Op (Control Odivu) (Name (#GPR0) @ Name (#GPR1) @ Enil)); (#RA, Name (#RA))] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] @@ -892,31 +896,21 @@ Proof. * intros rr; destruct rr; Simpl. destruct (preg_eq GPR0 g); Simpl. rewrite e. Simpl. (* Pjumptable *) + unfold goto_label in *. - destruct (nextblock b rs r) eqn:NB_r in *; try discriminate. - destruct (list_nth_z _ _) eqn:LI in *; try discriminate. - destruct (label_pos _ _ _) eqn:LPOS in *; try discriminate. - rewrite Pregmap.gso in H0; try discriminate. - rewrite Pregmap.gso in H0; try discriminate. + repeat (rewrite Pregmap.gso in H0; try discriminate). + destruct (nextblock _ _ _) eqn:NB; try discriminate. + destruct (list_nth_z _ _) eqn:LI; try discriminate. + destruct (label_pos _ _ _) eqn:LPOS; try discriminate. + destruct (nextblock b rs PC) eqn:MB2; try discriminate. inv H0. eexists; split; try split. - * simpl control_eval. - rewrite (H3 PC). - simpl. - unfold goto_label_deps. - Simpl. - rewrite H3. - destruct (rs r); try discriminate. - ++ - destruct (nextblock b rs PC) eqn:NB_PC in *; try discriminate. - inv H0. - - destruct (s (# PC)) eqn:sPC in *; try discriminate. - rewrite Pregmap.gso; try discriminate. - destruct (nextblock b rs r) eqn:NB_r in *; try discriminate. - destruct (list_nth_z _ _) eqn:LI in *; try discriminate. - destruct (label_pos _ _ _) eqn:LPOS in *; try discriminate. - destruct (nextblock b rs PC) eqn:NB_PC in *; try discriminate. - inv H1; try discriminate. - assumption. + * simpl control_eval. rewrite (H3 PC). simpl. Simpl. + rewrite H3. unfold nextblock in NB. rewrite Pregmap.gso in NB; try discriminate. rewrite NB. + rewrite LI. unfold goto_label_deps. rewrite LPOS. + unfold nextblock in MB2. rewrite Pregmap.gss in MB2. rewrite MB2. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (preg_eq GPR62 g); Simpl. rewrite e. Simpl. + destruct (preg_eq GPR63 g); Simpl. rewrite e. Simpl. (* Pj_l *) + unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. @@ -1116,6 +1110,11 @@ Proof. (* Pdivu *) - simpl in *. pose (H3 GPR0); rewrite e in H1; clear e. pose (H3 GPR1); rewrite e in H1; clear e. destruct (Val.divu _ _); try discriminate; auto. +(* Pjumptable *) + - simpl in *. repeat (rewrite H3 in H1). + destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. + unfold goto_label_deps in H1. unfold goto_label. Simpl. + destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. unfold goto_label_deps in H1. unfold goto_label. @@ -1232,6 +1231,9 @@ Proof. destruct (Val.divs _ _); try discriminate; auto. - simpl in *. pose (H3 GPR0); simpl in e; rewrite e; clear e. pose (H3 GPR1); simpl in e; rewrite e; clear e. destruct (Val.divu _ _); try discriminate; auto. + - simpl in *. repeat (rewrite H3). destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. + unfold goto_label_deps. unfold goto_label in H0. + destruct (label_pos _ _ _); auto. repeat (rewrite Pregmap.gso in H0; try discriminate). destruct (rs PC); auto. discriminate. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold goto_label in H0. destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. @@ -1573,6 +1575,7 @@ Definition string_of_control (op: control_op) : pstring := | Ocbu _ _ => "Ocbu" | Odiv => "Odiv" | Odivu => "Odivu" + | Ojumptable _ => "Ojumptable" | OError => "OError" | OIncremPC _ => "OIncremPC" end. -- cgit From 13effac30e636d890f891863f04c3d379713b34a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 14:23:35 +0100 Subject: jumptable avance --- mppa_k1c/Asmblockgenproof.v | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ea4d1918..f07cb6a4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -883,11 +883,16 @@ 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. @@ -895,7 +900,9 @@ Proof. * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. * unfold transl_comp_float32. exploreInst; simpl; eauto. * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - + simpl in TIC. inv TIC. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + simpl in TIC. monadInv TIC. simpl. eauto. - monadInv TIC. simpl; auto. Qed. -- cgit From 355736095980774b06c4feef9a313f1eb2528091 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 14:47:03 +0100 Subject: on avance sur la jumptable --- mppa_k1c/Asmblockgenproof.v | 5 ++--- mppa_k1c/PostpassSchedulingproof.v | 1 + 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index f07cb6a4..5d952d02 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1364,8 +1364,7 @@ Proof. all: rewrite <- C; try discriminate; unfold nextblock; Simpl. } intros. discriminate. + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. + admit. + (* MBreturn *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. @@ -1400,7 +1399,7 @@ Proof. generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. eapply agree_exten; eauto. intros. Simpl. discriminate. -Qed. +Admitted. Definition mb_remove_first (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 33912203..b59c381c 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -550,6 +550,7 @@ Proof. - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. Qed. Lemma eval_offset_preserved: -- cgit From 88448ee297d8894ecfb09d7925663cf6eb12cf01 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 15:44:07 +0100 Subject: Jump tables now work. There is still an "Admitted" subcase in a proof. --- mppa_k1c/Machregs.v | 3 +-- mppa_k1c/PostpassSchedulingOracle.ml | 1 + mppa_k1c/TargetPrinter.ml | 16 +++++++++++++--- 3 files changed, 15 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 4de37af4..60142797 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -152,8 +152,7 @@ Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mre Definition destroyed_by_cond (cond: condition): list mreg := nil. -(* Definition destroyed_by_jumptable: list mreg := R5 :: nil. *) -Definition destroyed_by_jumptable: list mreg := nil. +Definition destroyed_by_jumptable: list mreg := R62 :: R63 :: nil. Fixpoint destroyed_by_clobber (cl: list string): list mreg := match cl with diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2c39e342..25262af2 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -234,6 +234,7 @@ let ctl_flow_rec = function | 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} let control_rec i = match i with diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d4e2afc9..5bcb5cc8 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -268,7 +268,17 @@ module Target (*: TARGET*) = fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl | Ploopdo (r, lbl) -> fprintf oc " loopdo %a, %a\n" ireg r print_label lbl - + | Pjumptable (idx_reg, tbl) -> + let lbl = new_label() in + jumptables := (lbl, tbl) :: !jumptables; + let base_reg = if idx_reg=Asmblock.GPR63 then Asmblock.GPR62 else Asmblock.GPR63 in + fprintf oc "%s jumptable [ " comment; + List.iter (fun l -> fprintf oc "%a " print_label l) tbl; + fprintf oc "]\n"; + fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; + fprintf oc " lwz.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; + fprintf oc " igoto %a\n ;;\n" ireg base_reg + (* Load/Store instructions *) | Plb(rd, ra, ofs) -> fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra @@ -522,8 +532,8 @@ module Target (*: TARGET*) = let print_tbl oc (lbl, tbl) = fprintf oc "%a:\n" label lbl; List.iter - (fun l -> fprintf oc " .long %a - %a\n" - print_label l label lbl) + (fun l -> fprintf oc " .4byte %a\n" + print_label l) tbl in if !jumptables <> [] then begin -- cgit From af3389dbe670eecfaa8ad1a6a2b3ac1454eedfa8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Mar 2019 15:44:38 +0100 Subject: Décomposition de la preuve en une forward_simu_par_stuck et une forward_simu_par MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockdeps.v | 68 ++++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassSchedulingproof.v | 5 ++- 2 files changed, 72 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c6052337..0c6c74fb 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1459,3 +1459,71 @@ Module PChk := ParallelChecks L PosResourceSet. Definition bblock_para_check (p: Asmblock.bblock) : bool := PChk.is_parallelizable (trans_block p). + +Require Import Asmvliw. +Import PChk. + +Section SECT. +Variable Ge: genv. + +Theorem forward_simu_par: + forall rs1 m1 s1' b ge fn rs2 m2, + Ge = Genv ge fn -> + parexec_bblock ge fn b rs1 m1 (Next rs2 m2) -> + match_states (State rs1 m1) s1' -> + exists s2', + prun Ge (trans_block b) s1' (Some s2') + /\ match_states (State rs2 m2) s2'. +Proof. +Admitted. + +Theorem forward_simu_par_stuck: + forall rs1 m1 s1' b ge fn, + Ge = Genv ge fn -> + parexec_bblock ge fn b rs1 m1 Stuck -> + match_states (State rs1 m1) s1' -> + prun Ge (trans_block b) s1' None. +Proof. +Admitted. + +Theorem forward_simu_par_alt: + forall 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 -> + exists o2', + prun Ge (trans_block b) s1' o2' + /\ match_outcome o2 o2'. +Proof. + intros until o2. intros GENV MS PAREXEC. destruct o2 eqn:O2. + - exploit forward_simu_par; eauto. intros (s2' & PRUN & MS'). eexists. split. eassumption. + unfold match_outcome. eexists; split; auto. + - exploit forward_simu_par_stuck; eauto. intros. eexists; split; eauto. + constructor; auto. +Qed. + +Lemma bblock_para_check_correct: + forall ge fn bb rs m rs' m' o, + Ge = Genv ge fn -> + exec_bblock ge fn bb rs m = Next rs' m' -> + bblock_para_check bb = true -> + parexec_bblock ge fn bb rs m o -> + o = Next rs' m'. +Proof. + intros. unfold bblock_para_check in H1. + exploit forward_simu; eauto. eapply trans_state_match. + intros (s2' & EXEC & MS). + exploit forward_simu_par_alt. 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'. + - inv PRUN. inv H3. unfold exec in EXEC. assert (x = s2') by congruence. subst. clear H. + assert (m0 = s2') by (apply functional_extensionality; auto). subst. clear H4. + destruct o; try discriminate. inv MO. inv H. assert (s2' = x) by congruence. subst. + exploit state_equiv. split. eapply MS. eapply H4. intros. inv H. reflexivity. + - unfold match_outcome in MO. destruct o. + + inv MO. inv H3. discriminate. + + clear MO. unfold exec in EXEC. rewrite EXEC in PRUN. discriminate. +Qed. + +End SECT. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 1fc5c506..57a84480 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -780,7 +780,10 @@ Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: verify_par_bblock bundle = OK tt -> parexec_bblock (globalenv (semantics tprog)) f bundle rs m o -> o = Next rs' m'. Proof. -Admitted. + intros. unfold verify_par_bblock in H0. destruct (Asmblockdeps.bblock_para_check _) eqn:BPC; try discriminate. clear H0. + simpl in H. simpl in H1. + eapply Asmblockdeps.bblock_para_check_correct; eauto. +Qed. Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m' o: (* rs PC = Vptr b ofs -> *) (* needed somewhere ? *) -- cgit From 990dae34a6f132b3f7a3be438d47555805831085 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 22 Mar 2019 16:03:00 +0100 Subject: fix for Coq.8.8 ?? --- mppa_k1c/Asmblockdeps.v | 5 +++-- mppa_k1c/PostpassSchedulingproof.v | 2 -- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0c6c74fb..35138123 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1463,7 +1463,8 @@ Definition bblock_para_check (p: Asmblock.bblock) : bool := Require Import Asmvliw. Import PChk. -Section SECT. +Section SECT_PAR. + Variable Ge: genv. Theorem forward_simu_par: @@ -1526,4 +1527,4 @@ Proof. + clear MO. unfold exec in EXEC. rewrite EXEC in PRUN. discriminate. Qed. -End SECT. +End SECT_PAR. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 57a84480..f5a84db7 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -786,7 +786,6 @@ Proof. Qed. Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m' o: - (* rs PC = Vptr b ofs -> *) (* needed somewhere ? *) Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> @@ -797,7 +796,6 @@ Proof. Qed. Lemma seqexec_parexec_wio b ofs f bundle rs rs' m m': - (* rs PC = Vptr b ofs -> *) (* needed somewhere ? *) Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> -- cgit From 62505aeb0303126cac8f1e3f8fb06414c9cd4fb0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 22 Mar 2019 17:13:06 +0100 Subject: Avancement dans la preuve des bundles --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 51 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 35138123..a2941b6d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1460,13 +1460,48 @@ Module PChk := ParallelChecks L PosResourceSet. Definition bblock_para_check (p: Asmblock.bblock) : bool := PChk.is_parallelizable (trans_block p). -Require Import Asmvliw. +Require Import Asmvliw Permutation. Import PChk. Section SECT_PAR. Variable Ge: genv. +Theorem forward_simu_par_wio: + forall ge fn rs1 m1 s1' bdy1 bdy2 b rs m rs2 m2 rs3 m3, + Ge = Genv ge fn -> + match_states (State rs m) s1' -> + Permutation (bdy1 ++ bdy2) (body b) -> + parexec_wio_body ge bdy1 rs rs m m = Next rs1 m1 -> + parexec_control ge fn (exit b) rs (par_nextblock (Ptrofs.repr (size b)) rs rs1) m1 = Next rs2 m2 -> + parexec_wio_body ge bdy2 rs rs2 m m2 = Next rs3 m3 -> + exists s2', + res_eq (Some s2') (prun_iw Ge (trans_block b) s1' s1') + /\ match_states (State rs3 m3) s2'. +Proof. +Admitted. + +Lemma forward_simu_par_wio_stuck_bdy1: + forall ge fn rs m s1' bdy1 bdy2 b, + Ge = Genv ge fn -> + match_states (State rs m) s1' -> + Permutation (bdy1 ++ bdy2) (body b) -> + parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Stuck -> + res_eq None (prun_iw Ge (trans_block b) s1' s1'). +Proof. +Admitted. + +Lemma forward_simu_par_wio_stuck_bdy2: + forall ge fn rs m s1' bdy1 bdy2 b m' rs', + Ge = Genv ge fn -> + match_states (State rs m) s1' -> + Permutation (bdy1 ++ bdy2) (body b) -> + parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Next rs' m' -> + parexec_wio_body ge bdy2 rs rs' m m' = Stuck -> + res_eq None (prun_iw Ge (trans_block b) s1' s1'). +Proof. +Admitted. + Theorem forward_simu_par: forall rs1 m1 s1' b ge fn rs2 m2, Ge = Genv ge fn -> @@ -1476,7 +1511,15 @@ Theorem forward_simu_par: prun Ge (trans_block b) s1' (Some s2') /\ match_states (State rs2 m2) s2'. Proof. -Admitted. + intros until m2. intros GENV PAREXEC MS. + inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). + destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _) eqn:WIOEXIT; try discriminate. + unfold parexec_wio_bblock_aux in WIOEXIT. destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOBODY; try discriminate. + exploit forward_simu_par_wio; eauto. intros (s2' & PIW & MS'). + eexists. split. + econstructor; eauto. + eassumption. +Qed. Theorem forward_simu_par_stuck: forall rs1 m1 s1' b ge fn, @@ -1485,7 +1528,12 @@ Theorem forward_simu_par_stuck: match_states (State rs1 m1) s1' -> prun Ge (trans_block b) s1' None. Proof. -Admitted. + intros until fn. intros GENV PAREXEC MS. + inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). + destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _) eqn:WIOEXIT. + - econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy2; eauto. auto. + - clear WIO. econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy1; eauto. auto. +Qed. Theorem forward_simu_par_alt: forall rs1 m1 s1' b ge fn o2, -- cgit From c1b481f7eb46000110b71cfa9ea73694adc6b009 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 19:49:31 +0100 Subject: FIX BUG in TargetPrinter (nandd immediate wrongly printed as andd) --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 233dffec..29e0fef4 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -498,7 +498,7 @@ module Target (*: TARGET*) = | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnoril (rd, rs, imm) -> assert Archi.ptr64; -- cgit From b42c5b2d8677258fb2670e2de0c6dd9a1b1da3e3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 19:49:31 +0100 Subject: FIX BUG in TargetPrinter (nandd immediate wrongly printed as andd) --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d4e2afc9..9ab7ccd9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -492,7 +492,7 @@ module Target (*: TARGET*) = | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnoril (rd, rs, imm) -> assert Archi.ptr64; -- cgit From e2618b31dac9aa0cd859466b0e6af13ed00dc877 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 22 Mar 2019 19:49:31 +0100 Subject: FIX BUG in TargetPrinter (nandd immediate wrongly printed as andd) --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 69824852..41a6622a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -488,7 +488,7 @@ module Target (*: TARGET*) = | Pandil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Poril (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pnoril (rd, rs, imm) -> assert Archi.ptr64; -- cgit From 313db9c2b0b69fbbb2005ed90fd221932f87e5a0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 23 Mar 2019 08:00:52 +0100 Subject: slight simplification --- mppa_k1c/PostpassSchedulingproof.v | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f5a84db7..634f50bb 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -733,12 +733,11 @@ Proof. eapply verified_schedule_checks_alls_bundles; eauto. Qed. -Lemma find_bblock_forall_inv lb P: - (forall b, List.In b lb -> P b) -> - forall ofs b, find_bblock ofs lb = Some b -> P b. +Lemma find_bblock_Some_in lb: + forall ofs b, find_bblock ofs lb = Some b -> List.In b lb. Proof. induction lb; simpl; try congruence. - intros H ofs b. + intros ofs b. destruct (zlt ofs 0); try congruence. destruct (zeq ofs 0); eauto. intros X; inversion X; eauto. @@ -771,8 +770,8 @@ Proof. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. injection EQ1; intros; subst. monadInv EQ0. simpl in * |-. - intros; pattern bundle; eapply find_bblock_forall_inv; eauto. intros; exploit transf_blocks_checks_all_bundles; eauto. + intros; eapply find_bblock_Some_in; eauto. Qed. Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: -- cgit From 602ec8d0082be8939857d84231f47e2b0673e3ac Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 23 Mar 2019 08:42:53 +0100 Subject: un coup de pouce --- mppa_k1c/Machblockgenproof.v | 57 ++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 544f7f52..a599229b 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -276,15 +276,17 @@ Lemma find_label_is_end_block_is_label i l c bl: i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. Admitted. +Lemma find_label_at_begin l bh bl: + In l (header bh) + -> find_label l (bh :: bl) = Some (bh::bl). +Proof. + intro H; unfold find_label. destruct (is_label l bh) eqn:H0; auto. + rewrite <- is_label_correct_false in H0. tauto. +Qed. + + + -(* -Lemma find_label_is_end_block_is_label2 i bl: - forall bl', - (exists l, i=Mlabel l) -> - bl = add_to_new_bblock (trans_inst i) :: bl' -> - bl' = nil. -Admitted. - *) Lemma find_label_transcode_preserved: forall l c c', @@ -293,14 +295,16 @@ Lemma find_label_transcode_preserved: Proof. intros l c. remember (trans_code _) as bl. rewrite <- is_trans_code_inv in * |-. - induction Heqbl. - + intros. + induction Heqbl. + + (* Tr_nil *) + intros. exists (l::nil). split. apply in_eq. simpl. discriminate. - + intros. + + (* Tr_end_block *) + intros. exploit Mach_find_label_split; eauto. clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - subst. simpl. @@ -316,7 +320,8 @@ Proof. exists h. split; auto. rewrite (find_label_is_end_block_is_label i l c bl);auto. - + intros. + + (* Tr_add_label *) + intros. exploit Mach_find_label_split; eauto. clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - subst. simpl. @@ -330,24 +335,18 @@ Proof. exists (l :: nil). split; simpl; eauto. * destruct H0. simpl; eauto. - - exploit IHHeqbl; eauto. + - subst; assert (H: l0 <> l); try congruence; clear H0. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. destruct 1 as (h & H3 & H4). - simpl. - destruct (is_label l (add_label l0 bh)) eqn:H5. - (* - exists (l0::h). - ...*) - (* exists (l0::h). - split; simpl; eauto. - cut (is_label l bh = true). intros. - unfold find_label in H4. rewrite H1 in H4. - unfold add_label, concat; simpl. - destruct (trans_code c'). *) - - (* - exists h. - ...*) - + simpl; unfold is_label, add_label; simpl. + destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. + * destruct H5; try congruence. + exists (l0::h); simpl; intuition. + rewrite find_label_at_begin in H4. + apply f_equal. inversion H4 as [H5]. clear H4. + (* A FINIR *) + Admitted. -- cgit From 61e7b02ec6b25f4cf5ef7053b92c6eab3bcf616b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 24 Mar 2019 22:29:14 +0100 Subject: begin ternary --- mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 49 ++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 49 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 2577370c..989f87cb 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -117,6 +117,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c + | Oselect | Oselectl => op3 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c4338857..edb42d2f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -181,7 +181,9 @@ Inductive operation : Type := | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) (*c Boolean tests: *) - | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Oselect (**r [rd = if r3 then r2 else r1] *) + | Oselectl. (**r [rd = if r3 then r2 else r1] *) (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -250,6 +252,40 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | _, _ => None end. +Definition select (v0 : val) (v1 : val) (vselect : val) : option val := + match v0 with + | Vint i0 => + match v1 with + | Vint i1 => + match vselect with + | Vint iselect => + Some (Vint (if Int.cmp Ceq Int.zero iselect + then i0 + else i1)) + | _ => None + end + | _ => None + end + | _ => None + end. + +Definition selectl (v0 : val) (v1 : val) (vselect : val) : option val := + match v0 with + | Vlong i0 => + match v1 with + | Vlong i1 => + match vselect with + | Vint iselect => + Some (Vlong (if Int.cmp Ceq Int.zero iselect + then i0 + else i1)) + | _ => None + end + | _ => None + end + | _ => None + end. + Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -378,6 +414,8 @@ 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, v0::v1::vselect::nil => select v0 v1 vselect + | Oselectl, v0::v1::vselect::nil => selectl v0 v1 vselect | _, _ => None end. @@ -565,6 +603,9 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) + + | Oselect => (Tint :: Tint :: Tint :: nil, Tint) + | Oselectl => (Tlong :: Tlong :: Tlong :: nil, Tlong) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -799,6 +840,12 @@ 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; destruct v2; simpl in *; try discriminate. + inv H0... + (* selectl *) + - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate. + inv H0... Qed. End SOUNDNESS. -- cgit From f9b5ef305997c22b505865f2a2334b56115426b6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 07:18:39 +0100 Subject: going forward with select/selectl --- mppa_k1c/Op.v | 38 ++++++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index edb42d2f..8332621b 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -253,12 +253,12 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool end. Definition select (v0 : val) (v1 : val) (vselect : val) : option val := - match v0 with - | Vint i0 => - match v1 with - | Vint i1 => - match vselect with - | Vint iselect => + match vselect with + | Vint iselect => + match v0 with + | Vint i0 => + match v1 with + | Vint i1 => Some (Vint (if Int.cmp Ceq Int.zero iselect then i0 else i1)) @@ -270,12 +270,12 @@ Definition select (v0 : val) (v1 : val) (vselect : val) : option val := end. Definition selectl (v0 : val) (v1 : val) (vselect : val) : option val := - match v0 with - | Vlong i0 => - match v1 with - | Vlong i1 => - match vselect with - | Vint iselect => + match vselect with + | Vint iselect => + match v0 with + | Vlong i0 => + match v1 with + | Vlong i1 => Some (Vlong (if Int.cmp Ceq Int.zero iselect then i0 else i1)) @@ -1371,6 +1371,20 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + (* select *) + - inv H5; simpl in H1; try discriminate. + inv H4; simpl in H1; try discriminate. + inv H3; simpl in H1; try discriminate. + simpl. + injection H1; clear H1; intro H1. + destruct (Int.eq _ _); rewrite <- H1; simpl; TrivialExists. + (* selectl *) + - inv H5; simpl in H1; try discriminate. + inv H4; simpl in H1; try discriminate. + inv H3; simpl in H1; try discriminate. + simpl. + injection H1; clear H1; intro H1. + destruct (Int.eq _ _); rewrite <- H1; simpl; TrivialExists. Qed. Lemma eval_addressing_inj: -- cgit From ea45404a7ad40e952e0e4c415bdd1b7670ee515a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 07:36:46 +0100 Subject: progressing on select/selectl --- mppa_k1c/NeedOp.v | 1 + mppa_k1c/ValueAOp.v | 11 +++++++++++ 2 files changed, 12 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 989f87cb..ddebcb56 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -239,6 +239,7 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. + (* select *) Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index fb1977ea..7f599840 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -41,6 +41,15 @@ Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := | _, _ => Vbot end. +Definition select (v0 v1 vselect : aval) : aval := + match vselect with + | I iselect => + if Int.eq iselect Int.zero + then v0 + else v1 + | _ => Vbot + end. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -165,6 +174,8 @@ 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, v0::v1::vselect::nil => select v0 v1 vselect + | Oselectl, v0::v1::vselect::nil => select v0 v1 vselect | _, _ => Vbot end. -- cgit From 5a08ebe4174640c87d5cde45ec9b6a48a06ef4b8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 08:13:08 +0100 Subject: better Op select/selectl --- mppa_k1c/Op.v | 56 ++++++++++++++++++++++++-------------------------------- 1 file changed, 24 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 8332621b..39a599d8 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -252,38 +252,38 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | _, _ => None end. -Definition select (v0 : val) (v1 : val) (vselect : val) : option val := +Definition select (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with | Vint i0 => match v1 with | Vint i1 => - Some (Vint (if Int.cmp Ceq Int.zero iselect - then i0 - else i1)) - | _ => None + Vint (if Int.cmp Ceq Int.zero iselect + then i0 + else i1) + | _ => Vundef end - | _ => None + | _ => Vundef end - | _ => None + | _ => Vundef end. -Definition selectl (v0 : val) (v1 : val) (vselect : val) : option val := +Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with | Vlong i0 => match v1 with | Vlong i1 => - Some (Vlong (if Int.cmp Ceq Int.zero iselect - then i0 - else i1)) - | _ => None + Vlong (if Int.cmp Ceq Int.zero iselect + then i0 + else i1) + | _ => Vundef end - | _ => None + | _ => Vundef end - | _ => None + | _ => Vundef end. Definition eval_operation @@ -414,8 +414,8 @@ 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, v0::v1::vselect::nil => select v0 v1 vselect - | Oselectl, v0::v1::vselect::nil => selectl v0 v1 vselect + | Oselect, v0::v1::vselect::nil => Some (select v0 v1 vselect) + | Oselectl, v0::v1::vselect::nil => Some (selectl v0 v1 vselect) | _, _ => None end. @@ -841,11 +841,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* cmp *) - destruct (eval_condition cond vl m)... destruct b... (* select *) - - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate. - inv H0... + - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. (* selectl *) - - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate. - inv H0... + - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. Qed. End SOUNDNESS. @@ -1372,19 +1370,13 @@ Proof. destruct b; simpl; constructor. simpl; constructor. (* select *) - - inv H5; simpl in H1; try discriminate. - inv H4; simpl in H1; try discriminate. - inv H3; simpl in H1; try discriminate. - simpl. - injection H1; clear H1; intro H1. - destruct (Int.eq _ _); rewrite <- H1; simpl; TrivialExists. + - inv H3; simpl; try constructor. + inv H4; simpl; try constructor. + inv H2; simpl; constructor. (* selectl *) - - inv H5; simpl in H1; try discriminate. - inv H4; simpl in H1; try discriminate. - inv H3; simpl in H1; try discriminate. - simpl. - injection H1; clear H1; intro H1. - destruct (Int.eq _ _); rewrite <- H1; simpl; TrivialExists. + - inv H3; simpl; try constructor. + inv H4; simpl; try constructor. + inv H2; simpl; constructor. Qed. Lemma eval_addressing_inj: -- cgit From 6b475b3408c669cc217d8ee4ffc50471b22e0199 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 08:44:14 +0100 Subject: NeedOp advancing --- mppa_k1c/NeedOp.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index ddebcb56..a6ecb820 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -187,6 +187,46 @@ Proof. trivial. Qed. +Lemma select_sound: + forall v0 w0 v1 w1 v2 w2 x, + vagree v0 w0 (default x) -> + vagree v1 w1 (default x) -> + vagree v2 w2 (default x) -> + vagree (select v0 v1 v2) (select w0 w1 w2) x. +Proof. + unfold default; intros. + destruct x; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + inv H. inv H0. inv H1. simpl. + constructor. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + inv H. inv H0. inv H1. simpl. + constructor. +Qed. + +Lemma selectl_sound: + forall v0 w0 v1 w1 v2 w2 x, + vagree v0 w0 (default x) -> + vagree v1 w1 (default x) -> + vagree v2 w2 (default x) -> + vagree (selectl v0 v1 v2) (selectl w0 w1 w2) x. +Proof. + unfold default; intros. + destruct x; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + inv H. inv H0. inv H1. simpl. + constructor. +Qed. + Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. @@ -240,6 +280,9 @@ Proof. rewrite default_idem; trivial. rewrite default_idem; trivial. (* select *) +- apply select_sound; trivial. + (* selectl *) +- apply selectl_sound; trivial. Qed. Lemma operation_is_redundant_sound: -- cgit From a859702fe592beeb3a13ce2754dc0227cd6ea106 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 09:48:29 +0100 Subject: some version of select/selectl that runs through ValueAOp --- mppa_k1c/ValueAOp.v | 37 ++++++++++++++++++++++++++++++++----- 1 file changed, 32 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 7f599840..f181c0ea 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -44,10 +44,19 @@ Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := Definition select (v0 v1 vselect : aval) : aval := match vselect with | I iselect => - if Int.eq iselect Int.zero - then v0 - else v1 - | _ => Vbot + if Int.eq Int.zero iselect + then binop_int (fun x0 x1 => x0) v0 v1 + else binop_int (fun x0 x1 => x1) v0 v1 + | _ => Vtop + end. + +Definition selectl (v0 v1 vselect : aval) : aval := + match vselect with + | I iselect => + if Int.eq Int.zero iselect + then binop_long (fun x0 x1 => x0) v0 v1 + else binop_long (fun x0 x1 => x1) v0 v1 + | _ => Vtop end. Definition eval_static_operation (op: operation) (vl: list aval): aval := @@ -175,7 +184,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) | Oselect, v0::v1::vselect::nil => select v0 v1 vselect - | Oselectl, v0::v1::vselect::nil => select v0 v1 vselect + | Oselectl, v0::v1::vselect::nil => selectl v0 v1 vselect | _, _ => Vbot end. @@ -252,6 +261,24 @@ Proof. 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 *) + - inv H2; simpl; try constructor. + + destruct (Int.eq _ _); apply binop_int_sound; trivial. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. + (* selectl *) + - inv H2; simpl; try constructor. + + destruct (Int.eq _ _); apply binop_long_sound; trivial. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); + destruct a1; destruct a0; eauto; constructor. Qed. End SOUNDNESS. -- cgit From 42a33b26c657000d9145039d60a01ef2f67b7c2a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 09:56:48 +0100 Subject: draft comment --- mppa_k1c/Asmblock.v | 3 +++ 1 file changed, 3 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index fdec8ed2..ac4b7951 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -370,6 +370,9 @@ Inductive arith_name_rrr : Type := | Pfsbfw (**r float sub word *) | Pfmuld (**r float multiply double *) | Pfmulw (**r float multiply word *) +(* + | Pcmove (it: itest) (**r conditional move *) + *) . Inductive arith_name_rri32 : Type := -- cgit From 680ab18c29b5f72483780146d83e01c8ab498fb9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 10:45:26 +0100 Subject: progress on cmove --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 12 +++++++++--- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/PostpassSchedulingOracle.ml | 1 + mppa_k1c/TargetPrinter.ml | 4 ++++ 5 files changed, 17 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 0ca554ab..1e022218 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -208,6 +208,7 @@ Inductive instruction : Type := | 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 *) . (** Correspondance between Asmblock and Asm *) @@ -354,6 +355,7 @@ Definition basic_to_instruction (b: basic) := (** ARRR *) | PArithARRR Asmblock.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 | PArithARRR Asmblock.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR (Asmblock.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 (** ARRI32 *) | PArithARRI32 Asmblock.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ac4b7951..66181978 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -370,9 +370,6 @@ Inductive arith_name_rrr : Type := | Pfsbfw (**r float sub word *) | Pfmuld (**r float multiply double *) | Pfmulw (**r float multiply word *) -(* - | Pcmove (it: itest) (**r conditional move *) - *) . Inductive arith_name_rri32 : Type := @@ -414,6 +411,7 @@ Inductive arith_name_rri64 : Type := Inductive arith_name_arrr : Type := | Pmaddw (**r multiply add word *) | Pmaddl (**r multiply add long *) + | Pcmove (bt: btest) (**r conditional move *) . Inductive arith_name_arri32 : Type := @@ -1209,6 +1207,14 @@ 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) => + if (Val.cmp_bool c v2 (Vint Int.zero)) then v3 else v1 + | (Some c, Long) => + if (Val.cmpl_bool c v2 (Vlong Int64.zero)) then v3 else v1 + | (None, _) => Vundef + end end. Definition arith_eval_arri32 n v1 v2 v3 := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index ad96ae87..7ea4c9ee 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1433,6 +1433,7 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := match n with | Pmaddw => "Pmaddw" | Pmaddl => "Pmaddl" + | Pcmove _ => "Pcmove" end. Definition string_of_name_arri32 (n: arith_name_arri32): pstring := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 56b00c7e..27a4845f 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -128,6 +128,7 @@ let arith_rri64_str = function let arith_arrr_str = function | Pmaddw -> "Pmaddw" | Pmaddl -> "Pmaddl" + | Pcmove _ -> "Pcmove" let arith_ri32_str = "Pmake" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 41a6622a..9d816f36 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -504,6 +504,10 @@ module Target (*: TARGET*) = | Pmaddil (rd, rs, imm) -> fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pcmove (bt, rd, rcond, rs) -> + fprintf oc " cmove.%a %a? %a = %a\n" + bcond bt ireg rd ireg rcond ireg rs + let get_section_names name = let (text, lit) = match C2C.atom_sections name with -- cgit From bf1173b1609d04b8c99d1bdbcda4fffbb3745578 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 12:58:26 +0100 Subject: more on cmove --- mppa_k1c/Asmblock.v | 12 +++++- mppa_k1c/Asmblockgen.v | 7 ++++ mppa_k1c/Asmblockgenproof1.v | 87 ++++++++++++-------------------------------- mppa_k1c/Machregs.v | 2 +- 4 files changed, 42 insertions(+), 66 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 66181978..eb35ac99 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1210,9 +1210,17 @@ Definition arith_eval_arrr n v1 v2 v3 := | Pcmove bt => match cmp_for_btest bt with | (Some c, Int) => - if (Val.cmp_bool c v2 (Vint Int.zero)) then v3 else v1 + match Val.cmp_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end | (Some c, Long) => - if (Val.cmpl_bool c v2 (Vlong Int64.zero)) then v3 else v1 + match Val.cmpl_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end | (None, _) => Vundef end end. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c03e319c..89f3bac2 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -729,6 +729,13 @@ Definition transl_op do rd <- ireg_of res; transl_cond_op cmp rd args k + | Oselect, a0 :: a1 :: aS :: nil => + assertion (mreg_eq a0 res); + do r0 <- ireg_of a0; + do r1 <- ireg_of a1; + do rS <- ireg_of aS; + OK (Pcmove BTwnez r0 rS r1 ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5486a497..6239ed4a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1558,6 +1558,16 @@ Ltac TranslOpSimpl := [ apply exec_straight_one; reflexivity | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. +Lemma int_eq_comm: + forall (x y: int), + (Int.eq x y) = (Int.eq y x). +Proof. + intros. + unfold Int.eq. + unfold zeq. + destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. +Qed. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1645,69 +1655,20 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. -(* -- (* intconst *) - exploit loadimm32_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* longconst *) - exploit loadimm64_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* floatconst *) - destruct (Float.eq_dec n Float.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* singleconst *) - destruct (Float32.eq_dec n Float32.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* stackoffset *) - exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. auto with asmgen. -- (* addimm *) - exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* andimm *) - exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) - exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. - - - -- (* addlimm *) - exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. - -- (* andimm *) - exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) - exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -*) +- (* Oselect *) + econstructor; split. + + eapply exec_straight_one. + simpl; reflexivity. + + split. + * unfold select. + destruct (rs x1) eqn:eqX1; try constructor. + destruct (rs x) eqn:eqX; try constructor. + destruct (rs x0) eqn:eqX0; try constructor. + simpl. + rewrite int_eq_comm. + destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + * intros. + rewrite Pregmap.gso; congruence. Qed. (** Memory accesses *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 4de37af4..2b3fb1aa 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -210,7 +210,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect | Oselectl => true | _ => false end. -- cgit From e6a14b52554819995fed85c85a4acfedbb6ee3bc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 25 Mar 2019 13:23:43 +0100 Subject: selectl --- mppa_k1c/Asmblockgen.v | 7 +++++++ mppa_k1c/Asmblockgenproof1.v | 14 ++++++++++++++ 2 files changed, 21 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 89f3bac2..6e025381 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -736,6 +736,13 @@ Definition transl_op do rS <- ireg_of aS; OK (Pcmove BTwnez r0 rS r1 ::i k) + | Oselectl, a0 :: a1 :: aS :: nil => + assertion (mreg_eq a0 res); + do r0 <- ireg_of a0; + do r1 <- ireg_of a1; + do rS <- ireg_of aS; + OK (Pcmove BTwnez r0 rS r1 ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 6239ed4a..a1bd7124 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1669,6 +1669,20 @@ Opaque Int.eq. destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. +- (* Oselectl *) + econstructor; split. + + eapply exec_straight_one. + simpl; reflexivity. + + split. + * unfold select. + destruct (rs x1) eqn:eqX1; try constructor. + destruct (rs x) eqn:eqX; try constructor. + destruct (rs x0) eqn:eqX0; try constructor. + simpl. + rewrite int_eq_comm. + destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + * intros. + rewrite Pregmap.gso; congruence. Qed. (** Memory accesses *) -- cgit From 397cefa66b6b56818bd7602e349f98de9a74491b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 10:29:48 +0100 Subject: select basic operators --- mppa_k1c/SelectOp.vp | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index f6605c11..0dad482b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -61,6 +61,30 @@ Section SELECT. Context {hf: helper_functions}. +(** Stuff for select *) +Definition is_zero_expr (vt : expr) : expr := + Eop (Ocmp (Ccomp Ceq)) + (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). + +Definition is_nonzero_expr (vt : expr) : expr := + Eop (Ocmp (Ccomp Cne)) + (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). + +Definition bool_to_bitmask (et : expr) : expr := + Eop Oneg (et:::Enil). + +Definition not_bool_to_bitmask (et : expr) : expr := + Eop Osub (et:::(Eop (Ointconst Int.one) Enil):::Enil). + +Definition ternary_expand (et e0 e1 : expr) : expr := + Eop Oor + ((Eop Oand ((not_bool_to_bitmask et):::e1:::Enil))::: + (Eop Oand ((bool_to_bitmask et):::e0:::Enil))::: + Enil). + +Definition select_or_expand (et e0 e1 : expr) : expr := + ternary_expand (is_nonzero_expr et) e0 e1. + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := -- cgit From 87ccbf33d3c478f9894abcda8bc7c73b9cb7b5b4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 15:13:04 +0100 Subject: more on ternary --- mppa_k1c/SelectOp.vp | 10 ++-- mppa_k1c/SelectOpproof.v | 145 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 149 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 0dad482b..65364579 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -62,11 +62,11 @@ Section SELECT. Context {hf: helper_functions}. (** Stuff for select *) -Definition is_zero_expr (vt : expr) : expr := +Definition is_zero (vt : expr) : expr := Eop (Ocmp (Ccomp Ceq)) (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). -Definition is_nonzero_expr (vt : expr) : expr := +Definition is_nonzero (vt : expr) : expr := Eop (Ocmp (Ccomp Cne)) (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). @@ -76,14 +76,14 @@ Definition bool_to_bitmask (et : expr) : expr := Definition not_bool_to_bitmask (et : expr) : expr := Eop Osub (et:::(Eop (Ointconst Int.one) Enil):::Enil). -Definition ternary_expand (et e0 e1 : expr) : expr := +Definition ternary_expand (e0 e1 et : expr) : expr := Eop Oor ((Eop Oand ((not_bool_to_bitmask et):::e1:::Enil))::: (Eop Oand ((bool_to_bitmask et):::e0:::Enil))::: Enil). -Definition select_or_expand (et e0 e1 : expr) : expr := - ternary_expand (is_nonzero_expr et) e0 e1. +Definition select_or_expand (e0 e1 et: expr) : expr := + ternary_expand e0 e1 (is_zero et). (** ** Constants **) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 89af39ee..0637256d 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -92,7 +92,7 @@ Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable m: mem. - + (* Helper lemmas - from SplitLongproof.v *) Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto. @@ -163,6 +163,149 @@ Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> va eval_expr ge sp e m le b y -> exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. +Definition is_zero_sem (vt : val) : val := + match vt with + | Vint x => Vint (if Int.eq x Int.zero then Int.one else Int.zero) + | _ => Vundef + end. + +Theorem eval_is_zero: unary_constructor_sound is_zero is_zero_sem. +Proof. + red; intros. + unfold is_zero_sem, is_zero; simpl. + TrivialExists. + - constructor. + + exact H. + + constructor; econstructor; constructor. + - simpl. + destruct x; simpl; try congruence. + unfold Vtrue, Vfalse. + predSpec Int.eq Int.eq_spec i Int.zero; reflexivity. +Qed. + +Definition is_nonzero_sem (vt : val) : val := + match vt with + | Vint x => Vint (if Int.eq x Int.zero then Int.zero else Int.one) + | _ => Vundef + end. + +Theorem eval_is_nonzero: unary_constructor_sound is_nonzero is_nonzero_sem. +Proof. + red; intros. + unfold is_zero_sem, is_zero; simpl. + TrivialExists. + - constructor. + + exact H. + + constructor; econstructor; constructor. + - simpl. + destruct x; simpl; try congruence. + unfold Vtrue, Vfalse. + predSpec Int.eq Int.eq_spec i Int.zero; reflexivity. +Qed. + + +Definition ternary_constructor_sound (cstr: expr -> expr -> expr -> expr) (sem: val -> val -> val -> val) : Prop := + forall le a x b y c z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + eval_expr ge sp e m le c z -> + exists v, eval_expr ge sp e m le (cstr a b c) v /\ Val.lessdef (sem x y z) v. + +Lemma int_eq_commut : forall x y, + Int.eq x y = Int.eq y x. +Proof. + unfold Int.eq. + intros. + unfold zeq. + destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. +Qed. + +Theorem eval_select_or_expand : ternary_constructor_sound select_or_expand select. +Proof. + unfold ternary_constructor_sound, ternary_expand. + intros. + TrivialExists. + constructor. + - econstructor. + constructor. + econstructor. + constructor. + unfold is_zero. + econstructor. + constructor. + eassumption. + constructor. + econstructor. + constructor. + simpl. + reflexivity. + constructor. + simpl. + reflexivity. + constructor. + econstructor. + constructor. + simpl. + reflexivity. + constructor. + simpl. + reflexivity. + constructor. + eassumption. + constructor. + simpl. + reflexivity. + - constructor. + econstructor. + constructor. + econstructor. + constructor. + unfold is_zero. + econstructor. + constructor. + eassumption. + constructor. + econstructor. + constructor. + simpl. + reflexivity. + constructor. + simpl. + reflexivity. + constructor. + simpl. + reflexivity. + constructor. + eassumption. + constructor. + simpl. + reflexivity. + constructor. + - simpl. + unfold select. + destruct z; simpl; trivial. + destruct x; simpl; trivial; try (destruct (Int.eq i Int.zero); simpl; rewrite <- (Val.or_commut Vundef); simpl; reflexivity). + destruct y; simpl; trivial; + try (destruct (Int.eq i Int.zero); simpl; reflexivity). + rewrite int_eq_commut. predSpec Int.eq Int.eq_spec Int.zero i. + * simpl. + rewrite Int.sub_idem. + rewrite Int.and_commut. + rewrite Int.and_zero. + rewrite Int.or_commut. + rewrite Int.or_zero. + rewrite Int.and_commut. + rewrite Int.and_mone. + reflexivity. + * simpl. + rewrite Int.and_commut. + rewrite Int.and_mone. + rewrite Int.and_commut. + rewrite Int.and_zero. + rewrite Int.or_zero. + reflexivity. +Qed. + Theorem eval_addrsymbol: forall le id ofs, exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. -- cgit From 38797928d764b838194dbc685643ef9eb13603da Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 26 Mar 2019 16:32:14 +0100 Subject: Un peu d'avancement --- mppa_k1c/Asmblockdeps.v | 276 +++++++++++++++++++++++++++++++++++++++++++++++- mppa_k1c/Asmvliw.v | 15 ++- 2 files changed, 287 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a2941b6d..6417055a 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1465,8 +1465,281 @@ Import PChk. Section SECT_PAR. +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) + || (rewrite assign_diff by (auto; try discriminate; try (apply ppos_discr; try discriminate; congruence); try (apply ppos_pmem_discr); + try (apply not_eq_sym; apply ppos_discr; try discriminate; congruence); try (apply not_eq_sym; apply ppos_pmem_discr); auto)) + || (rewrite assign_eq) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Arguments Pos.add: simpl never. +Arguments ppos: simpl never. + Variable Ge: genv. +Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' mw' i: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_arith_instr ge i rsr rsw = rsw' -> mw = mw' -> + exists sw', + macro_prun Ge (trans_arith i) sw sr sr = Some sw' + /\ match_states (State rsw' mw') sw'. +Proof. + intros GENV MSR MSW PARARITH MWEQ. subst. inv MSR. inv MSW. + unfold parexec_arith_instr. destruct i. +(* Ploadsymbol *) + - destruct i. eexists; split; [| split]. + * simpl. reflexivity. + * Simpl. + * simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRR *) + - eexists; split; [| split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRI32 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRI64 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF32 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF64 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRR *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRI32 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRI64 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +Qed. + +Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi rsw' mw': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_basic_instr ge bi rsr rsw mr mw = Next rsw' mw' -> + exists sw', + macro_prun Ge (trans_basic bi) sw sr sr = Some sw' + /\ match_states (State rsw' mw') sw'. +Proof. + intros GENV MSR MSW H. + destruct bi. +(* Arith *) + - simpl in H. inversion H. subst rsw' mw'. simpl macro_prun. eapply trans_arith_par_correct; eauto. +(* Load *) + - simpl in H. destruct i. + unfold parexec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H. inv MSR; inv MSW; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; pose (H0 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| + Simpl| + intros rr; destruct rr; Simpl; + destruct (ireg_eq g rd); [ + subst; Simpl| + Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. +(* Store *) + - simpl in H. destruct i. + unfold parexec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate. + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate. inv H; inv MSR; inv MSW. + eexists; split; try split. + * simpl. rewrite EVALOFF. rewrite H. rewrite (H0 ra). rewrite (H0 rs). rewrite MEML. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. +(* Allocframe *) + - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. + inv H. inv MSR. inv MSW. eexists. split; try split. + * simpl. Simpl. rewrite (H0 GPR12). rewrite H. rewrite MEMAL. rewrite MEMS. Simpl. + rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. +(* Freeframe *) + - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rsr GPR12) eqn:SPeq; try discriminate. + destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv MSR. inv MSW. + eexists. split; try split. + * simpl. rewrite (H0 GPR12). rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. + Simpl. rewrite (H0 GPR12). rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR14)]]; subst; Simpl. +(* Pget *) + - simpl in H. destruct rs eqn:rseq; try discriminate. inv H. inv MSR. inv MSW. + eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* Pset *) + - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv MSR; inv MSW. + eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. +(* Pnop *) + - simpl in H. inv H. inv MSR. inv MSW. eexists. split; try split. assumption. assumption. +Qed. + +Theorem forward_simu_par_body: + forall bdy ge fn rsr mr sr rsw mw sw rs' m', + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_wio_body ge bdy rsr rsw mr mw = Next rs' m' -> + exists s', + prun_iw Ge (trans_body bdy) sw sr = Some s' + /\ match_states (State rs' m') s'. +Proof. + induction bdy. + - intros until m'. intros GENV MSR MSW WIO. + simpl in WIO. inv WIO. inv MSR. inv MSW. + eexists. split; [| split]. + * simpl. reflexivity. + * assumption. + * assumption. + - intros until m'. intros GENV MSR MSW WIO. + simpl in WIO. destruct (parexec_basic_instr _ _ _ _ _ _) eqn:PARBASIC; try discriminate. + exploit forward_simu_par_wio_basic. 4: eapply PARBASIC. all: eauto. + intros (sw' & MPRUN & MS'). simpl prun_iw. rewrite MPRUN. + eapply IHbdy; eauto. +Qed. + +Theorem forward_simu_par_control ctl rsr mr sr rsw mw sw ge fn rs' m': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_control ge fn (Some ctl) rsr rsw mw = Next rs' m' -> + exists s', + macro_prun Ge (trans_control ctl) sw sr sr = Some s' + /\ match_states (State rs' m') s'. +Proof. + intros GENV MSR MSW H0. + simpl in *. destruct ctl; destruct i; try discriminate. + all: try (inv H0; inv MSR; inv MSW; eexists; split; [| split]; [ simpl; reflexivity | Simpl | intros rr; destruct rr; Simpl]). + (* Pj_l *) + + unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. inv H0. + inv MSR; inv MSW. + eexists; split; try split. + * simpl. rewrite (H0 PC). unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + (* Pcb *) + + destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold par_eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold par_eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0; inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + (* Pcbu *) + + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold par_eval_branch in H0. destruct (Val_cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold par_eval_branch in H0. destruct (Val_cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0; inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. +Qed. + +Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy ex sz rs' m': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> + exists s', + prun_iw Ge ((trans_body bdy) ++ trans_pcincr sz (trans_exit ex)) sr sw = Some s' + /\ match_states (State rs' m') s'. +Proof. + intros. unfold parexec_wio_bblock_aux in H2. + destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB; try discriminate. + exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. + intros (s' & RUNB & MS'). + destruct ex. + - exploit forward_simu_par_control. 4: eapply H2. all: eauto. +Admitted. + + Theorem forward_simu_par_wio: forall ge fn rs1 m1 s1' bdy1 bdy2 b rs m rs2 m2 rs3 m3, Ge = Genv ge fn -> @@ -1491,8 +1764,7 @@ Lemma forward_simu_par_wio_stuck_bdy1: Proof. Admitted. -Lemma forward_simu_par_wio_stuck_bdy2: - forall ge fn rs m s1' bdy1 bdy2 b m' rs', +Lemma forward_simu_par_wio_stuck_bdy2 ge fn rs m s1' bdy1 bdy2 b m' rs': Ge = Genv ge fn -> match_states (State rs m) s1' -> Permutation (bdy1 ++ bdy2) (body b) -> diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 36c68acd..0490e502 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -78,6 +78,17 @@ Definition parexec_load (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) | _ => Stuck end. +Definition parexec_store (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) + (s: ireg) (a: ireg) (ofs: offset) := + match (eval_offset ge ofs) with + | OK ptr => + match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end + | _ => Stuck + end. + (* rem: parexec_store = exec_store *) (** * basic instructions *) @@ -89,7 +100,7 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | PLoadRRO n d a ofs => parexec_load (load_chunk n) rsr rsw mr mw d a ofs - | PStoreRRO n s a ofs => exec_store ge (store_chunk n) rsr mr s a ofs + | PStoreRRO n s a ofs => parexec_store (store_chunk n) rsr rsw mr mw s a ofs | Pallocframe sz pos => let (mw, stk) := Mem.alloc mr 0 sz in @@ -163,7 +174,7 @@ Warning: in m PC is assumed to be already pointing on the next instruction ! Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) (res: option bool) := match res with | Some true => par_goto_label f l rsr rsw mw - | Some false => Next rsw mw + | Some false => Next (rsw # PC <- (rsr PC)) mw | None => Stuck end. -- cgit From 8550881e22693a5cd5078980f3e9c23bf6f63424 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 26 Mar 2019 17:30:18 +0100 Subject: 1 coup de pouce ! --- mppa_k1c/Asmblockdeps.v | 38 +++++++++++++++++++++++++++++--------- 1 file changed, 29 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6417055a..4843b41d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1722,16 +1722,18 @@ Proof. * intros rr; destruct rr; Simpl. Qed. -Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy ex sz rs' m': +Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ trans_pcincr sz (trans_exit ex). + +Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz rs' m': Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> exists s', - prun_iw Ge ((trans_body bdy) ++ trans_pcincr sz (trans_exit ex)) sr sw = Some s' + prun_iw Ge (trans_block_aux bdy sz ex) sr sw = Some s' /\ match_states (State rs' m') s'. Proof. - intros. unfold parexec_wio_bblock_aux in H2. + intros. unfold parexec_wio_bblock_aux in H2. unfold trans_block_aux. destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB; try discriminate. exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. intros (s' & RUNB & MS'). @@ -1739,7 +1741,24 @@ Proof. - exploit forward_simu_par_control. 4: eapply H2. all: eauto. Admitted. +Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs' m' rs2 m2: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> + parexec_wio_body ge bdy2 rsr rs' mr m' = Next rs2 m2 -> + exists s2', + res_eq (Some s2') (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr) + /\ match_states (State rs2 m2) s2'. +Admitted. +Theorem trans_block_perserves_permutation ge fn bdy1 bdy2 b: + Ge = Genv ge fn -> + Permutation (bdy1 ++ bdy2) (body b) -> + Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). +Admitted. + +(* replaced by forward_simu_par_wio_bblock Theorem forward_simu_par_wio: forall ge fn rs1 m1 s1' bdy1 bdy2 b rs m rs2 m2 rs3 m3, Ge = Genv ge fn -> @@ -1753,6 +1772,7 @@ Theorem forward_simu_par_wio: /\ match_states (State rs3 m3) s2'. Proof. Admitted. +*) Lemma forward_simu_par_wio_stuck_bdy1: forall ge fn rs m s1' bdy1 bdy2 b, @@ -1785,12 +1805,12 @@ Theorem forward_simu_par: Proof. intros until m2. intros GENV PAREXEC MS. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). - destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _) eqn:WIOEXIT; try discriminate. - unfold parexec_wio_bblock_aux in WIOEXIT. destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOBODY; try discriminate. - exploit forward_simu_par_wio; eauto. intros (s2' & PIW & MS'). - eexists. split. - econstructor; eauto. - eassumption. + exploit trans_block_perserves_permutation; eauto. + intros Perm. + remember (parexec_wio_bblock_aux _ _ _ _ _ _ _) as pwb. + destruct pwb; try congruence. + exploit forward_simu_par_wio_bblock; eauto. intros (s2' & PIW & MS'). + unfold prun; eexists; split; eauto. Qed. Theorem forward_simu_par_stuck: -- cgit From 464a6b67e374440c22b6abcbca938f84fbf13871 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 19:22:49 +0100 Subject: implemented ternary pattern --- mppa_k1c/SelectOp.vp | 12 +++++++++++- mppa_k1c/SelectOpproof.v | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 65364579..2a07afc4 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -299,7 +299,17 @@ Nondetfunction or (e1: expr) (e2: expr) := then Eop (Ororimm n2) (t1:::Enil) 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) + | t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil) + | (Eop Oand ((Eop Osub ((Eop (Ocmp (Ccomp Ceq)) + (y1:::(Eop (Ointconst zero1) Enil):::Enil)):::(Eop (Ointconst one1) Enil):::Enil)):::v1:::Enil)), + (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccomp Ceq)) + (y0:::(Eop (Ointconst zero0) Enil):::Enil)):::Enil)):::v0:::Enil)) => + if same_expr_pure y0 y1 + && Int.eq zero0 Int.zero + && Int.eq zero1 Int.zero + && Int.eq one1 Int.one + then Eop Oselect (v0:::v1:::y0:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 0637256d..221d994f 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -696,6 +696,52 @@ 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 *) + rename v12 into ret0. + rename v7 into ret1. + 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. + predSpec Int.eq Int.eq_spec one1 Int.one; simpl; try exact DEFAULT. + TrivialExists. + simpl in *. + unfold select. + f_equal. + inv H6. + inv H7. + inv H9. + inv H11. + inv H14. + inv H12. + inv H16. + 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 v10 with v4 in * by congruence. + rename v4 into vselect. + destruct vselect; simpl; trivial. + rewrite (Val.and_commut _ ret0). + rewrite Val.or_commut. + destruct ret0; simpl; trivial. + rewrite (Val.and_commut _ ret1). + rewrite Val.or_commut. + destruct ret1; simpl; trivial. + rewrite int_eq_commut. + destruct (Int.eq i1 Int.zero); simpl. + + rewrite Int.sub_idem. + rewrite Int.and_zero. + rewrite Int.or_commut. + rewrite Int.or_zero. + rewrite Int.and_mone. + reflexivity. + + rewrite Int.and_mone. + rewrite Int.neg_zero. + rewrite Int.and_zero. + rewrite Int.or_zero. + reflexivity. - apply DEFAULT. Qed. -- cgit From 0a708569d1fe213305c731cfa32fd6a41f5811e3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 19:59:04 +0100 Subject: some progress --- mppa_k1c/SelectOp.vp | 9 ++++----- mppa_k1c/SelectOpproof.v | 22 ++++++++-------------- 2 files changed, 12 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2a07afc4..8f188f7e 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -300,14 +300,13 @@ 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 Osub ((Eop (Ocmp (Ccomp Ceq)) - (y1:::(Eop (Ointconst zero1) Enil):::Enil)):::(Eop (Ointconst one1) Enil):::Enil)):::v1:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccomp Ceq)) - (y0:::(Eop (Ointconst zero0) Enil):::Enil)):::Enil)):::v0:::Enil)) => + | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccomp Ceq)) + (y0:::(Eop (Ointconst zero0) Enil):::Enil)):::Enil)):::v0:::Enil)), + (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccomp Cne)) + (y1:::(Eop (Ointconst zero1) Enil):::Enil)):::Enil)):::v1:::Enil)) => if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - && Int.eq one1 Int.one then Eop Oselect (v0:::v1:::y0:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 221d994f..23a883ec 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -696,13 +696,10 @@ 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 *) - rename v12 into ret0. - rename v7 into ret1. + - (* select *) Show. 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. - predSpec Int.eq Int.eq_spec one1 Int.one; simpl; try exact DEFAULT. TrivialExists. simpl in *. unfold select. @@ -711,28 +708,25 @@ Proof. inv H7. inv H9. inv H11. - inv H14. inv H12. - inv H16. + inv H15. 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 v10 with v4 in * by congruence. + replace v9 with v4 in * by congruence. rename v4 into vselect. destruct vselect; simpl; trivial. - rewrite (Val.and_commut _ ret0). + rewrite (Val.and_commut _ v6). + destruct v6; simpl; trivial. + rewrite (Val.and_commut _ v11). rewrite Val.or_commut. - destruct ret0; simpl; trivial. - rewrite (Val.and_commut _ ret1). - rewrite Val.or_commut. - destruct ret1; simpl; trivial. + destruct v11; simpl; trivial. rewrite int_eq_commut. destruct (Int.eq i1 Int.zero); simpl. - + rewrite Int.sub_idem. - rewrite Int.and_zero. + + rewrite Int.and_zero. rewrite Int.or_commut. rewrite Int.or_zero. rewrite Int.and_mone. -- cgit From a408c35b6853d6a2607a739e82e004d41ccf7942 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 20:08:58 +0100 Subject: ternary begins working --- mppa_k1c/SelectOp.vp | 10 +++++----- mppa_k1c/SelectOpproof.v | 14 ++++++-------- 2 files changed, 11 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 8f188f7e..2ad264c9 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -300,13 +300,13 @@ 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 (Ccomp Ceq)) - (y0:::(Eop (Ointconst zero0) Enil):::Enil)):::Enil)):::v0:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccomp Cne)) - (y1:::(Eop (Ointconst zero1) Enil):::Enil)):::Enil)):::v1:::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 + && Int.eq zero1 Int.zero then Eop Oselect (v0:::v1:::y0:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 23a883ec..243dc531 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -696,7 +696,7 @@ 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 *) Show. + - (* 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. @@ -708,22 +708,20 @@ Proof. inv H7. inv H9. inv H11. - inv H12. - inv H15. 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 v9 with v4 in * by congruence. + replace v8 with v4 in * by congruence. rename v4 into vselect. destruct vselect; simpl; trivial. - rewrite (Val.and_commut _ v6). - destruct v6; simpl; trivial. - rewrite (Val.and_commut _ v11). + rewrite (Val.and_commut _ v5). + destruct v5; simpl; trivial. + rewrite (Val.and_commut _ v9). rewrite Val.or_commut. - destruct v11; simpl; trivial. + destruct v9; simpl; trivial. rewrite int_eq_commut. destruct (Int.eq i1 Int.zero); simpl. + rewrite Int.and_zero. -- cgit From 6af4f0a6a9afa41a7b835d805ad8532d2f04f2e1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 20:15:40 +0100 Subject: ternary / cmove demo now works --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 9d816f36..4be94390 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -505,8 +505,8 @@ module Target (*: TARGET*) = fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pcmove (bt, rd, rcond, rs) -> - fprintf oc " cmove.%a %a? %a = %a\n" - bcond bt ireg rd ireg rcond ireg rs + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd ireg rs let get_section_names name = let (text, lit) = -- cgit From 3ff674c7c3ad5237fa4223596563c2b6e09cd8cf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 20:20:33 +0100 Subject: cmoved works --- mppa_k1c/PostpassSchedulingOracle.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 27a4845f..9e6e819c 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -416,7 +416,7 @@ type real_instruction = | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd - | Maddw | Maddd + | Maddw | Maddd | Cmoved | Make | Nop | Sxwd | Zxwd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld @@ -483,7 +483,8 @@ let ab_inst_to_real = function | "Pfixedudrzz" -> Fixedudz | "Pfixeddrzz_i32" -> Fixeddz | "Pfixedudrzz_i32" -> Fixedudz - + | "Pcmove" -> Cmoved + | "Plb" -> Lbs | "Plbu" -> Lbz | "Plh" -> Lhs @@ -532,7 +533,7 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd -> + | Nxord | Andnd | Ornd | Cmoved -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) @@ -585,7 +586,7 @@ let real_inst_to_latency = function | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make - | Sxwd | Zxwd | Fcompw | Fcompd + | Sxwd | Zxwd | Fcompw | Fcompd | Cmoved -> 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 *) -- cgit From 45cab18f8f9fc1db4f9877333c09d5a5cb2dc64d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 20:37:16 +0100 Subject: rm cruft --- mppa_k1c/SelectOp.vp | 24 -------- mppa_k1c/SelectOpproof.v | 152 +++-------------------------------------------- 2 files changed, 9 insertions(+), 167 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2ad264c9..d01b7616 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -61,30 +61,6 @@ Section SELECT. Context {hf: helper_functions}. -(** Stuff for select *) -Definition is_zero (vt : expr) : expr := - Eop (Ocmp (Ccomp Ceq)) - (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). - -Definition is_nonzero (vt : expr) : expr := - Eop (Ocmp (Ccomp Cne)) - (vt:::(Eop (Ointconst Int.zero) Enil):::Enil). - -Definition bool_to_bitmask (et : expr) : expr := - Eop Oneg (et:::Enil). - -Definition not_bool_to_bitmask (et : expr) : expr := - Eop Osub (et:::(Eop (Ointconst Int.one) Enil):::Enil). - -Definition ternary_expand (e0 e1 et : expr) : expr := - Eop Oor - ((Eop Oand ((not_bool_to_bitmask et):::e1:::Enil))::: - (Eop Oand ((bool_to_bitmask et):::e0:::Enil))::: - Enil). - -Definition select_or_expand (e0 e1 et: expr) : expr := - ternary_expand e0 e1 (is_zero et). - (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 243dc531..8f8e5b67 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -162,149 +162,6 @@ Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> va eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. - -Definition is_zero_sem (vt : val) : val := - match vt with - | Vint x => Vint (if Int.eq x Int.zero then Int.one else Int.zero) - | _ => Vundef - end. - -Theorem eval_is_zero: unary_constructor_sound is_zero is_zero_sem. -Proof. - red; intros. - unfold is_zero_sem, is_zero; simpl. - TrivialExists. - - constructor. - + exact H. - + constructor; econstructor; constructor. - - simpl. - destruct x; simpl; try congruence. - unfold Vtrue, Vfalse. - predSpec Int.eq Int.eq_spec i Int.zero; reflexivity. -Qed. - -Definition is_nonzero_sem (vt : val) : val := - match vt with - | Vint x => Vint (if Int.eq x Int.zero then Int.zero else Int.one) - | _ => Vundef - end. - -Theorem eval_is_nonzero: unary_constructor_sound is_nonzero is_nonzero_sem. -Proof. - red; intros. - unfold is_zero_sem, is_zero; simpl. - TrivialExists. - - constructor. - + exact H. - + constructor; econstructor; constructor. - - simpl. - destruct x; simpl; try congruence. - unfold Vtrue, Vfalse. - predSpec Int.eq Int.eq_spec i Int.zero; reflexivity. -Qed. - - -Definition ternary_constructor_sound (cstr: expr -> expr -> expr -> expr) (sem: val -> val -> val -> val) : Prop := - forall le a x b y c z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - eval_expr ge sp e m le c z -> - exists v, eval_expr ge sp e m le (cstr a b c) v /\ Val.lessdef (sem x y z) v. - -Lemma int_eq_commut : forall x y, - Int.eq x y = Int.eq y x. -Proof. - unfold Int.eq. - intros. - unfold zeq. - destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. -Qed. - -Theorem eval_select_or_expand : ternary_constructor_sound select_or_expand select. -Proof. - unfold ternary_constructor_sound, ternary_expand. - intros. - TrivialExists. - constructor. - - econstructor. - constructor. - econstructor. - constructor. - unfold is_zero. - econstructor. - constructor. - eassumption. - constructor. - econstructor. - constructor. - simpl. - reflexivity. - constructor. - simpl. - reflexivity. - constructor. - econstructor. - constructor. - simpl. - reflexivity. - constructor. - simpl. - reflexivity. - constructor. - eassumption. - constructor. - simpl. - reflexivity. - - constructor. - econstructor. - constructor. - econstructor. - constructor. - unfold is_zero. - econstructor. - constructor. - eassumption. - constructor. - econstructor. - constructor. - simpl. - reflexivity. - constructor. - simpl. - reflexivity. - constructor. - simpl. - reflexivity. - constructor. - eassumption. - constructor. - simpl. - reflexivity. - constructor. - - simpl. - unfold select. - destruct z; simpl; trivial. - destruct x; simpl; trivial; try (destruct (Int.eq i Int.zero); simpl; rewrite <- (Val.or_commut Vundef); simpl; reflexivity). - destruct y; simpl; trivial; - try (destruct (Int.eq i Int.zero); simpl; reflexivity). - rewrite int_eq_commut. predSpec Int.eq Int.eq_spec Int.zero i. - * simpl. - rewrite Int.sub_idem. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_commut. - rewrite Int.or_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - reflexivity. - * simpl. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_zero. - reflexivity. -Qed. Theorem eval_addrsymbol: forall le id ofs, @@ -669,6 +526,15 @@ Proof. discriminate. Qed. +Lemma int_eq_commut: forall x y : int, + (Int.eq x y) = (Int.eq y x). +Proof. + intros. + predSpec Int.eq Int.eq_spec x y; + predSpec Int.eq Int.eq_spec y x; + congruence. +Qed. + Theorem eval_or: binary_constructor_sound or Val.or. Proof. unfold or; red; intros. -- cgit From d52a401b30a7618c1b36cc1e6bd514c843136690 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 20:51:34 +0100 Subject: ternary unsigned --- mppa_k1c/SelectOp.vp | 9 +++++++++ mppa_k1c/SelectOpproof.v | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d01b7616..13650a2c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -285,6 +285,15 @@ Nondetfunction or (e1: expr) (e2: expr) := && Int.eq zero1 Int.zero then Eop Oselect (v0:::v1:::y0:::Enil) 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 Eop Oselect (v0:::v1:::y0:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 8f8e5b67..d35c4b6d 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -600,6 +600,44 @@ Proof. rewrite Int.and_zero. 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 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. + rewrite (Val.and_commut _ v5). + destruct v5; simpl; trivial. + rewrite (Val.and_commut _ v9). + rewrite Val.or_commut. + destruct v9; simpl; trivial. + rewrite int_eq_commut. + destruct (Int.eq i1 Int.zero); simpl. + + rewrite Int.and_zero. + rewrite Int.or_commut. + rewrite Int.or_zero. + rewrite Int.and_mone. + reflexivity. + + rewrite Int.and_mone. + rewrite Int.neg_zero. + rewrite Int.and_zero. + rewrite Int.or_zero. + reflexivity. - apply DEFAULT. Qed. -- cgit From 3750a2ad965b4959f6535aeeb9075dbd1a7c0527 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 Mar 2019 22:44:31 +0100 Subject: selectl generation --- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof1.v | 16 ++++- mppa_k1c/Op.v | 4 +- mppa_k1c/SelectLong.vp | 25 +++++++ mppa_k1c/SelectLongproof.v | 160 +++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/ValueAOp.v | 12 ++-- 6 files changed, 205 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 6e025381..cf0b2a0a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -741,7 +741,7 @@ Definition transl_op do r0 <- ireg_of a0; do r1 <- ireg_of a1; do rS <- ireg_of aS; - OK (Pcmove BTwnez r0 rS r1 ::i k) + OK (Pcmove BTdnez r0 rS r1 ::i k) | _, _ => Error(msg "Asmgenblock.transl_op") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index a1bd7124..16663522 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1568,6 +1568,16 @@ Proof. destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. Qed. +Lemma int64_eq_comm: + forall (x y: int64), + (Int64.eq x y) = (Int64.eq y x). +Proof. + intros. + unfold Int64.eq. + unfold zeq. + destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. +Qed. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1674,13 +1684,13 @@ Opaque Int.eq. + eapply exec_straight_one. simpl; reflexivity. + split. - * unfold select. + * unfold selectl. destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. simpl. - rewrite int_eq_comm. - destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + rewrite int64_eq_comm. + destruct (Int64.eq i Int64.zero); simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. Qed. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 39a599d8..ec3f1077 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -271,12 +271,12 @@ Definition select (v0 : val) (v1 : val) (vselect : val) : val := Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := match vselect with - | Vint iselect => + | Vlong iselect => match v0 with | Vlong i0 => match v1 with | Vlong i1 => - Vlong (if Int.cmp Ceq Int.zero iselect + Vlong (if Int64.cmp Ceq Int64.zero iselect then i0 else i1) | _ => Vundef diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 0c3618d7..26ae55f6 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -278,9 +278,34 @@ 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 (v0:::v1:::y0:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | _, _ => Eop Oorl (e1:::e2:::Enil) end. +(* + | (Eop Oandl ((Eop Ocast32signed + ((Eop Oneg ((Eop (Ocmp (Ccompluimm Ceq zero0)) + (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), + (Eop Oandl ((Eop Ocast32signed + ((Eop Oneg ((Eop (Ocmp (Ccompluimm 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 (v0:::v1:::y0:::Enil) + else Eop Oorl (e1:::e2:::Enil) *) + Nondetfunction xorlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else match e2 with diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 79187338..09a7cfff 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -414,6 +414,16 @@ Proof. - TrivialExists. Qed. + +Lemma int64_eq_commut: forall x y : int64, + (Int64.eq x y) = (Int64.eq y x). +Proof. + intros. + predSpec Int64.eq Int64.eq_spec x y; + predSpec Int64.eq Int64.eq_spec y x; + congruence. +Qed. + Theorem eval_orl: binary_constructor_sound orl Val.orl. Proof. unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. @@ -423,6 +433,156 @@ 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. + unfold selectl. + 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 i1 Int64.zero); 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. + (* + - (* selectl unsigned *) + 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. + unfold selectl. + 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 i1 Int64.zero); 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. + + *) - TrivialExists. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f181c0ea..a3843301 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -52,8 +52,8 @@ Definition select (v0 v1 vselect : aval) : aval := Definition selectl (v0 v1 vselect : aval) : aval := match vselect with - | I iselect => - if Int.eq Int.zero iselect + | L iselect => + if Int64.eq Int64.zero iselect then binop_long (fun x0 x1 => x0) v0 v1 else binop_long (fun x0 x1 => x1) v0 v1 | _ => Vtop @@ -272,12 +272,8 @@ Proof. destruct a1; destruct a0; eauto; constructor. (* selectl *) - inv H2; simpl; try constructor. - + destruct (Int.eq _ _); apply binop_long_sound; trivial. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); + + destruct (Int64.eq _ _); apply binop_long_sound; trivial. + + destruct (Int64.eq _ _); destruct a1; destruct a0; eauto; constructor. Qed. -- cgit From 0d8f4f46407b1634fba4f6cd46ba4955a7859863 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 27 Mar 2019 07:53:34 +0100 Subject: match some 'and' --- mppa_k1c/SelectLong.vp | 8 +++++++- mppa_k1c/SelectLongproof.v | 36 +++++++++++++++++++++++++++--------- 2 files changed, 34 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 26ae55f6..9bf35581 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -258,7 +258,13 @@ Nondetfunction andl (e1: expr) (e2: expr) := | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 | (Eop Onotl (t1:::Enil)), t2 => Eop Oandnl (t1:::t2:::Enil) - | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) + | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) + | (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) | _, _ => Eop Oandl (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 09a7cfff..49abc7c7 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -390,6 +390,15 @@ Proof. - TrivialExists. Qed. +Lemma int64_eq_commut: forall x y : int64, + (Int64.eq x y) = (Int64.eq y x). +Proof. + intros. + predSpec Int64.eq Int64.eq_spec x y; + predSpec Int64.eq Int64.eq_spec y x; + congruence. +Qed. + Theorem eval_andl: binary_constructor_sound andl Val.andl. Proof. unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. @@ -398,6 +407,24 @@ Proof. - InvEval. apply eval_andlimm; auto. - (*andn*) InvEval. TrivialExists. simpl. congruence. - (*andn reverse*) InvEval. rewrite Val.andl_commut. TrivialExists; simpl. congruence. +- (* selectl *) + InvEval. + predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; TrivialExists. + + constructor. econstructor; constructor. + constructor; try constructor; try constructor; try eassumption. + + simpl in *. f_equal. inv H6. + unfold selectl. + simpl. + destruct v3; simpl; trivial. + rewrite int64_eq_commut. + destruct (Int64.eq i Int64.zero); simpl. + * replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. + destruct y; simpl; trivial. + * replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. + destruct y; simpl; trivial. + rewrite Int64.and_commut. rewrite Int64.and_mone. reflexivity. + + constructor. econstructor. constructor. econstructor. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. eassumption. constructor. + + simpl in *. congruence. - TrivialExists. Qed. @@ -415,15 +442,6 @@ Proof. Qed. -Lemma int64_eq_commut: forall x y : int64, - (Int64.eq x y) = (Int64.eq y x). -Proof. - intros. - predSpec Int64.eq Int64.eq_spec x y; - predSpec Int64.eq Int64.eq_spec y x; - congruence. -Qed. - Theorem eval_orl: binary_constructor_sound orl Val.orl. Proof. unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. -- cgit From 86d7e48d92d602e2349032883b7b753bbea81a3c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 27 Mar 2019 09:47:32 +0100 Subject: improvements on cmoved etc. --- mppa_k1c/SelectLong.vp | 21 +++--------- mppa_k1c/SelectLongproof.v | 79 ++-------------------------------------------- 2 files changed, 7 insertions(+), 93 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 9bf35581..6c34de19 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -259,14 +259,16 @@ Nondetfunction andl (e1: expr) (e2: expr) := | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 | (Eop Onotl (t1:::Enil)), t2 => Eop Oandnl (t1:::t2:::Enil) | 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) - | _, _ => Eop Oandl (e1:::e2:::Enil) - end. +*) Nondetfunction orlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else @@ -295,22 +297,9 @@ Nondetfunction orl (e1: expr) (e2: expr) := && Int64.eq zero1 Int64.zero then Eop Oselectl (v0:::v1:::y0:::Enil) else Eop Oorl (e1:::e2:::Enil) - | _, _ => Eop Oorl (e1:::e2:::Enil) end. - -(* - | (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccompluimm Ceq zero0)) - (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), - (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccompluimm 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 (v0:::v1:::y0:::Enil) - else Eop Oorl (e1:::e2:::Enil) *) + Nondetfunction xorlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 49abc7c7..dd4cfa69 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -407,6 +407,7 @@ Proof. - InvEval. apply eval_andlimm; auto. - (*andn*) InvEval. TrivialExists. simpl. congruence. - (*andn reverse*) InvEval. rewrite Val.andl_commut. TrivialExists; simpl. congruence. + (* - (* selectl *) InvEval. predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; TrivialExists. @@ -424,7 +425,7 @@ Proof. destruct y; simpl; trivial. rewrite Int64.and_commut. rewrite Int64.and_mone. reflexivity. + constructor. econstructor. constructor. econstructor. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. eassumption. constructor. - + simpl in *. congruence. + + simpl in *. congruence. *) - TrivialExists. Qed. @@ -525,82 +526,6 @@ Proof. rewrite Int64.and_zero. rewrite Int64.or_zero. reflexivity. - (* - - (* selectl unsigned *) - 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. - unfold selectl. - 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 i1 Int64.zero); 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. - + *) - TrivialExists. Qed. -- cgit From 25f47289ff5d9b497d45d3f4efbf4c5df56829a9 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Mar 2019 16:25:40 +0100 Subject: Avancement dans Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 197 +++++++++++++++++++++++++++--------------------- mppa_k1c/Asmvliw.v | 7 +- 2 files changed, 113 insertions(+), 91 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4843b41d..df1acc6f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -555,10 +555,10 @@ Fixpoint trans_body (b: list basic) : list L.macro := | b :: lb => (trans_basic b) :: (trans_body lb) end. -Definition trans_pcincr (sz: Z) (k: L.macro) := [(#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k]. +Definition trans_pcincr (sz: Z) (k: L.macro) := (#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k. Definition trans_block (b: Asmblock.bblock) : L.bblock := - trans_body (body b) ++ trans_pcincr (size b) (trans_exit (exit b)). + trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. Proof. @@ -795,7 +795,7 @@ Lemma forward_simu_control: exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> match_states (State rs m) s -> exists s', - exec Ge (trans_pcincr (size b) (trans_exit ex)) s = Some s' + exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = Some s' /\ match_states (State rs2 m2) s'. Proof. intros. destruct ex. @@ -972,7 +972,7 @@ Lemma exec_trans_pcincr_exec: forall rs m s b, match_states (State rs m) s -> exists s', - exec Ge (trans_pcincr (size b) (trans_exit (exit b))) s = exec Ge [trans_exit (exit b)] s' + exec Ge (trans_pcincr (size b) (trans_exit (exit b)) :: nil) s = exec Ge [trans_exit (exit b)] s' /\ match_states (State (nextblock b rs) m) s'. Proof. intros. @@ -1633,96 +1633,110 @@ Proof. eapply IHbdy; eauto. Qed. -Theorem forward_simu_par_control ctl rsr mr sr rsw mw sw ge fn rs' m': +Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn (Some ctl) rsr rsw mw = Next rs' m' -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Next rs' m' -> exists s', - macro_prun Ge (trans_control ctl) sw sr sr = Some s' + macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' /\ match_states (State rs' m') s'. Proof. intros GENV MSR MSW H0. - simpl in *. destruct ctl; destruct i; try discriminate. - all: try (inv H0; inv MSR; inv MSW; eexists; split; [| split]; [ simpl; reflexivity | Simpl | intros rr; destruct rr; Simpl]). - (* Pj_l *) - + unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. inv H0. - inv MSR; inv MSW. - eexists; split; try split. - * simpl. rewrite (H0 PC). unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - (* Pcb *) - + destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold par_eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. - inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - ++ unfold par_eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. - inv H0; inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - (* Pcbu *) - + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold par_eval_branch in H0. destruct (Val_cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. - inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - ++ unfold par_eval_branch in H0. destruct (Val_cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. - inv H0; inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. -Qed. + simpl in *. + destruct ex. + - destruct c; destruct i; try discriminate. + all: try (inv H0; inv MSR; inv MSW; eexists; split; [| split]; [simpl; rewrite (H0 PC); reflexivity | Simpl | intros rr; destruct rr; unfold par_nextblock; Simpl]). + + (* Pj_l *) + + simpl in H0. unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ _) eqn:NB; try discriminate. inv H0. + inv MSR; inv MSW. + eexists; split; try split. + * simpl. rewrite (H0 PC). unfold goto_label_deps. rewrite LPOS. Simpl. + unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. + (* Pcb *) + + simpl in H0. destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold par_eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ _) eqn:NB; try discriminate. + inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. Admitted. (* rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold par_eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0; inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + (* Pcbu *) + + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + ++ unfold par_eval_branch in H0. destruct (Val_cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + ++ unfold par_eval_branch in H0. destruct (Val_cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + inv H0; inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + +++ inv H0. inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. rewrite VALCMP. + reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. +Qed. *) +(* +Theorem forward_simu_par_nextblockge ge fn rsr rsw mr mw sr sw sz rs' ex rs'' m'': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + par_nextblock (Ptrofs.repr sz) rsr rsw = rs' -> + parexec_control ge fn ex rsr rs' mw = Next rs'' m'' -> + exists s'', + macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s'' + /\ match_states (State rs'' m'') s''. *) -Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ trans_pcincr sz (trans_exit ex). +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 rs' m': Ge = Genv ge fn -> @@ -1741,6 +1755,7 @@ Proof. - exploit forward_simu_par_control. 4: eapply H2. all: eauto. Admitted. + Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs' m' rs2 m2: Ge = Genv ge fn -> match_states (State rsr mr) sr -> @@ -1752,8 +1767,14 @@ Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs /\ match_states (State rs2 m2) s2'. Admitted. -Theorem trans_block_perserves_permutation ge fn bdy1 bdy2 b: - Ge = Genv ge fn -> +Lemma trans_body_perserves_permutation bdy1 bdy2: + Permutation bdy1 bdy2 -> + Permutation (trans_body bdy1) (trans_body bdy2). +Proof. + induction 1; simpl; econstructor; eauto. +Qed. + +Theorem trans_block_perserves_permutation bdy1 bdy2 b: Permutation (bdy1 ++ bdy2) (body b) -> Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). Admitted. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 0490e502..d3349344 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -151,8 +151,8 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := instruction ([nextblock]) or branching to a label ([goto_label]). *) (* TODO: factoriser ? *) -Definition par_nextblock size_b (rsr rsw: regset) := - rsw#PC <- (Val.offset_ptr rsr#PC size_b). +Definition par_nextblock size_b (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC size_b). (* TODO: factoriser ? *) Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := @@ -240,7 +240,8 @@ end. Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rs: regset) (m: mem): outcome := match parexec_wio_body bdy rs rs m m with | Next rsw mw => - let rsw := par_nextblock size_b rs rsw in + let rs := par_nextblock size_b rs in + let rsw := par_nextblock size_b rsw in parexec_control f ext rs rsw mw | Stuck => Stuck end. -- cgit From 2a353a9380100279769d3a0f65a64b3114e3b11a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Mar 2019 17:24:44 +0100 Subject: Preuve du forward_simu du parexec_wio_bblock_aux --- mppa_k1c/Asmblockdeps.v | 116 ++++++++++++++++++++++++++---------------------- mppa_k1c/Asmvliw.v | 14 +++--- 2 files changed, 70 insertions(+), 60 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index df1acc6f..a65be8a8 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1659,111 +1659,121 @@ Proof. (* Pcb *) + simpl in H0. destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. ++ unfold par_eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ _) eqn:NB; try discriminate. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. Admitted. (* rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. + unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. +++ inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. ++ unfold par_eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. inv H0; inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. + unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. +++ inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. (* Pcbu *) - + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. + + simpl in H0. destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. ++ unfold par_eval_branch in H0. destruct (Val_cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. + unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. +++ inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. ++ unfold par_eval_branch in H0. destruct (Val_cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (rsr PC) eqn:NB; try discriminate. + +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. inv H0; inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). - rewrite CFB. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite NB. reflexivity. + rewrite CFB. Simpl. rewrite (H0 r). + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. + unfold goto_label_deps. rewrite LPOS. + unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. +++ inv H0. inv MSR; inv MSW. eexists; split; try split. * simpl. rewrite (H0 PC). rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. rewrite VALCMP. + unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. -Qed. *) -(* -Theorem forward_simu_par_nextblockge ge fn rsr rsw mr mw sr sw sz rs' ex rs'' m'': - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - par_nextblock (Ptrofs.repr sz) rsr rsw = rs' -> - parexec_control ge fn ex rsr rs' mw = Next rs'' m'' -> - exists s'', - macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s'' - /\ match_states (State rs'' m'') s''. *) + * intros rr; destruct rr; unfold par_nextblock; Simpl. + - simpl in *. inv MSR. inv MSW. inv H0. eexists. split. + rewrite (H1 PC). simpl. reflexivity. + split. Simpl. + intros rr. destruct rr; unfold par_nextblock; Simpl. +Qed. Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). +Lemma prun_iw_app_some: + forall c c' sr sw s' s'', + prun_iw Ge c sw sr = Some s' -> + prun_iw Ge c' s' sr = Some s'' -> + prun_iw Ge (c ++ c') sw sr = Some s''. +Proof. + induction c. + - simpl. intros. congruence. + - intros. simpl in *. destruct (macro_prun _ _ _ _); auto. eapply IHc; eauto. discriminate. +Qed. + Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz rs' m': Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> + parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr rsw mr mw = Next rs' m' -> exists s', - prun_iw Ge (trans_block_aux bdy sz ex) sr sw = Some s' + prun_iw Ge (trans_block_aux bdy sz ex) sw sr = Some s' /\ match_states (State rs' m') s'. Proof. intros. unfold parexec_wio_bblock_aux in H2. unfold trans_block_aux. destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB; try discriminate. exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. intros (s' & RUNB & MS'). - destruct ex. - - exploit forward_simu_par_control. 4: eapply H2. all: eauto. -Admitted. - + exploit forward_simu_par_control. 4: eapply H2. all: eauto. + intros (s'' & RUNCTL & MS''). + eexists. split. + eapply prun_iw_app_some. eassumption. unfold prun_iw. rewrite RUNCTL. reflexivity. eassumption. +Qed. Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs' m' rs2 m2: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> + parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw = Next rs' m' -> parexec_wio_body ge bdy2 rsr rs' mr m' = Next rs2 m2 -> exists s2', - res_eq (Some s2') (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr) + res_eq (Some s2') (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sw sr) /\ match_states (State rs2 m2) s2'. Admitted. @@ -1800,7 +1810,7 @@ Lemma forward_simu_par_wio_stuck_bdy1: Ge = Genv ge fn -> match_states (State rs m) s1' -> Permutation (bdy1 ++ bdy2) (body b) -> - parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Stuck -> + parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs rs m m = Stuck -> res_eq None (prun_iw Ge (trans_block b) s1' s1'). Proof. Admitted. @@ -1809,7 +1819,7 @@ Lemma forward_simu_par_wio_stuck_bdy2 ge fn rs m s1' bdy1 bdy2 b m' rs': Ge = Genv ge fn -> match_states (State rs m) s1' -> Permutation (bdy1 ++ bdy2) (body b) -> - parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Next rs' m' -> + parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs rs m m = Next rs' m' -> parexec_wio_body ge bdy2 rs rs' m m' = Stuck -> res_eq None (prun_iw Ge (trans_block b) s1' s1'). Proof. @@ -1828,7 +1838,7 @@ Proof. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). exploit trans_block_perserves_permutation; eauto. intros Perm. - remember (parexec_wio_bblock_aux _ _ _ _ _ _ _) as pwb. + remember (parexec_wio_bblock_aux _ _ _ _ _ _ _ _ _) as pwb. destruct pwb; try congruence. exploit forward_simu_par_wio_bblock; eauto. intros (s2' & PIW & MS'). unfold prun; eexists; split; eauto. @@ -1843,7 +1853,7 @@ Theorem forward_simu_par_stuck: Proof. intros until fn. intros GENV PAREXEC MS. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). - destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _) eqn:WIOEXIT. + destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _ _ _) eqn:WIOEXIT. - econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy2; eauto. auto. - clear WIO. econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy1; eauto. auto. Qed. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index d3349344..8407f28d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -233,25 +233,25 @@ Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) | Pbuiltin ef args res => Stuck (**r treated specially below *) end - | None => Next rsw mw + | None => Next (rsw#PC <- (rsr#PC)) mw end. -Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rs: regset) (m: mem): outcome := - match parexec_wio_body bdy rs rs m m with +Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rsr rsw: regset) (mr mw: mem): outcome := + match parexec_wio_body bdy rsr rsw mr mw with | Next rsw mw => - let rs := par_nextblock size_b rs in + let rsr := par_nextblock size_b rsr in let rsw := par_nextblock size_b rsw in - parexec_control f ext rs rsw mw + parexec_control f ext rsr rsw mw | Stuck => Stuck end. 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 m. + parexec_wio_bblock_aux f (body b) (exit b) (Ptrofs.repr (size b)) rs rs m m. Definition parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem) (o: outcome): Prop := exists bdy1 bdy2, Permutation (bdy1++bdy2) (body b) /\ - o=match parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs m with + o=match parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs rs m m with | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw | Stuck => Stuck end. -- cgit From c4620aef8a80a9ca088493db5558b84bd3561052 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 27 Mar 2019 17:36:21 +0100 Subject: Proof of the entire forward simulation (still stuck to do + permutations) --- mppa_k1c/Asmblockdeps.v | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a65be8a8..2bd78449 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1773,9 +1773,16 @@ Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw = Next rs' m' -> parexec_wio_body ge bdy2 rsr rs' mr m' = Next rs2 m2 -> exists s2', - res_eq (Some s2') (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)) sw sr = Some s2' /\ match_states (State rs2 m2) s2'. -Admitted. +Proof. + intros. exploit forward_simu_par_wio_bblock_aux. 4: eapply H2. all: eauto. + intros (s' & RUNAUX & MS'). + exploit forward_simu_par_body. 4: eapply H3. all: eauto. + intros (s'' & RUNBDY2 & MS''). + eexists. split. + eapply prun_iw_app_some. eassumption. eassumption. eassumption. +Qed. Lemma trans_body_perserves_permutation bdy1 bdy2: Permutation bdy1 bdy2 -> @@ -1841,7 +1848,7 @@ Proof. remember (parexec_wio_bblock_aux _ _ _ _ _ _ _ _ _) as pwb. destruct pwb; try congruence. exploit forward_simu_par_wio_bblock; eauto. intros (s2' & PIW & MS'). - unfold prun; eexists; split; eauto. + unfold prun. unfold res_eq. eexists; split; eauto. Qed. Theorem forward_simu_par_stuck: -- cgit From 0b1ffa332effdc452b1c76dcbcc738908360f5a8 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 Mar 2019 17:45:08 +0100 Subject: dealing with permutations --- mppa_k1c/Asmblockdeps.v | 111 +++++++++++++++++++++++--------- mppa_k1c/abstractbb/Parallelizability.v | 18 ++++++ 2 files changed, 100 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index df1acc6f..b608255f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1756,16 +1756,22 @@ Proof. Admitted. -Theorem forward_simu_par_wio_bblock ge fn rsr mr sr rsw mw sw bdy1 bdy2 ex sz rs' m' rs2 m2: +Theorem forward_simu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz rs' m' rs2 m2: Ge = Genv ge fn -> match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr mr = Next rs' m' -> parexec_wio_body ge bdy2 rsr rs' mr m' = Next rs2 m2 -> exists s2', - res_eq (Some s2') (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr) + prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr = Some s2' /\ match_states (State rs2 m2) s2'. -Admitted. +Proof. + intros; exploit forward_simu_par_wio_bblock_aux. 4: eauto. all: eauto. + intros (s1' & X1 & X2). + exploit (forward_simu_par_body bdy2). 4: eauto. all: eauto. + intros (s2' & X3 & X4). + eexists; split; eauto. + erewrite prun_iw_app_Some; eauto. +Qed. Lemma trans_body_perserves_permutation bdy1 bdy2: Permutation bdy1 bdy2 -> @@ -1774,46 +1780,89 @@ Proof. induction 1; simpl; econstructor; eauto. Qed. +Lemma trans_body_app bdy1: forall bdy2, + trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). +Proof. + induction bdy1; simpl; congruence. +Qed. + Theorem trans_block_perserves_permutation bdy1 bdy2 b: Permutation (bdy1 ++ bdy2) (body b) -> Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). +Proof. + intro H; unfold trans_block, trans_block_aux. + eapply perm_trans. + - eapply Permutation_app_tail. + apply trans_body_perserves_permutation. + apply Permutation_sym; eapply H. + - rewrite trans_body_app. rewrite <-! app_assoc. + apply Permutation_app_head. + apply Permutation_app_comm. +Qed. + +Lemma forward_simu_par_wio_basic_Stuck 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 -> + parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> + macro_prun Ge (trans_basic bi) sw sr sr = None. Admitted. -(* replaced by forward_simu_par_wio_bblock -Theorem forward_simu_par_wio: - forall ge fn rs1 m1 s1' bdy1 bdy2 b rs m rs2 m2 rs3 m3, +Lemma forward_simu_par_body_Stuck bdy: forall ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> - match_states (State rs m) s1' -> - Permutation (bdy1 ++ bdy2) (body b) -> - parexec_wio_body ge bdy1 rs rs m m = Next rs1 m1 -> - parexec_control ge fn (exit b) rs (par_nextblock (Ptrofs.repr (size b)) rs rs1) m1 = Next rs2 m2 -> - parexec_wio_body ge bdy2 rs rs2 m m2 = Next rs3 m3 -> - exists s2', - res_eq (Some s2') (prun_iw Ge (trans_block b) s1' s1') - /\ match_states (State rs3 m3) s2'. + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_wio_body ge bdy rsr rsw mr mw = Stuck -> + prun_iw Ge (trans_body bdy) sw sr = None. Proof. + induction bdy. + - intros until sw. intros GENV MSR MSW WIO. + simpl in WIO. inv WIO. + - intros until sw. intros GENV MSR MSW WIO. + simpl in WIO. destruct (parexec_basic_instr _ _ _ _ _ _) eqn:PARBASIC. + * exploit forward_simu_par_wio_basic. 4: eapply PARBASIC. all: eauto. + intros (sw' & MPRUN & MS'). simpl prun_iw. rewrite MPRUN. + eapply IHbdy; eauto. + * exploit forward_simu_par_wio_basic_Stuck. 4: eapply PARBASIC. all: eauto. + intros X; simpl; rewrite X; auto. +Qed. + +Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Stuck -> + macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Admitted. -*) -Lemma forward_simu_par_wio_stuck_bdy1: - forall ge fn rs m s1' bdy1 bdy2 b, +Lemma forward_simu_par_wio_stuck_bdy1 ge fn rs m s1' bdy1 sz ex: Ge = Genv ge fn -> match_states (State rs m) s1' -> - Permutation (bdy1 ++ bdy2) (body b) -> - parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Stuck -> - res_eq None (prun_iw Ge (trans_block b) s1' s1'). + parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rs m = Stuck -> + prun_iw Ge ((trans_block_aux bdy1 sz ex)) s1' s1' = None. Proof. -Admitted. + unfold parexec_wio_bblock_aux, trans_block_aux; intros. + destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB. + * exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. + intros (s' & RUNB & MS'). + erewrite prun_iw_app_Some; eauto. + exploit forward_simu_par_control_Stuck. 4: eauto. all: eauto. + simpl. intros X; rewrite X. auto. + * apply prun_iw_app_None. eapply forward_simu_par_body_Stuck. 4: eauto. all: eauto. +Qed. -Lemma forward_simu_par_wio_stuck_bdy2 ge fn rs m s1' bdy1 bdy2 b m' rs': +Lemma forward_simu_par_wio_stuck_bdy2 ge fn rs m s1' bdy1 bdy2 sz ex m' rs': Ge = Genv ge fn -> match_states (State rs m) s1' -> - Permutation (bdy1 ++ bdy2) (body b) -> - parexec_wio_bblock_aux ge fn bdy1 (exit b) (Ptrofs.repr (size b)) rs m = Next rs' m' -> + parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rs m = Next rs' m' -> parexec_wio_body ge bdy2 rs rs' m m' = Stuck -> - res_eq None (prun_iw Ge (trans_block b) s1' s1'). + prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) s1' s1'=None. Proof. -Admitted. + intros; exploit forward_simu_par_wio_bblock_aux. 4: eauto. all: eauto. + intros (s2' & X1 & X2). + erewrite prun_iw_app_Some; eauto. + eapply forward_simu_par_body_Stuck. 4: eauto. all: eauto. +Qed. Theorem forward_simu_par: forall rs1 m1 s1' b ge fn rs2 m2, @@ -1831,7 +1880,7 @@ Proof. remember (parexec_wio_bblock_aux _ _ _ _ _ _ _) as pwb. destruct pwb; try congruence. exploit forward_simu_par_wio_bblock; eauto. intros (s2' & PIW & MS'). - unfold prun; eexists; split; eauto. + unfold prun; simpl; eexists; split; eauto. Qed. Theorem forward_simu_par_stuck: @@ -1843,9 +1892,13 @@ Theorem forward_simu_par_stuck: Proof. intros until fn. intros GENV PAREXEC MS. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). + exploit trans_block_perserves_permutation; eauto. + intros Perm. destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _) eqn:WIOEXIT. - econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy2; eauto. auto. - - clear WIO. econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy1; eauto. auto. + - clear WIO. econstructor; eauto. split; eauto. + simpl; apply prun_iw_app_None; auto. + eapply forward_simu_par_wio_stuck_bdy1; eauto. Qed. Theorem forward_simu_par_alt: diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index b6d1f142..065c0922 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -79,6 +79,24 @@ Proof. + intros H1; rewrite H1; simpl; auto. Qed. +Lemma prun_iw_app_None p1: forall m1 old p2, + prun_iw p1 m1 old = None -> + prun_iw (p1++p2) m1 old = None. +Proof. + induction p1; simpl; try congruence. + intros; destruct (macro_prun _ _ _); simpl; auto. +Qed. + +Lemma prun_iw_app_Some p1: forall m1 old m2 p2, + prun_iw p1 m1 old = Some m2 -> + prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. +Proof. + induction p1; simpl; try congruence. + intros; destruct (macro_prun _ _ _); simpl; auto. + congruence. +Qed. + + End PARALLEL. End ParallelSemantics. -- cgit From 5b6508b35616c2cf1aa93d01e63359a59332d8d0 Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 28 Mar 2019 16:56:06 +0100 Subject: find_label_transcode_preserved proof --- mppa_k1c/Machblockgenproof.v | 51 ++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 47 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index a599229b..f669e6bd 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -274,7 +274,17 @@ Lemma find_label_is_end_block_is_label i l c bl: is_end_block (trans_inst i) bl -> is_trans_code c bl -> i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. -Admitted. +Proof. + intros H H0 H1. + unfold find_label. + remember (is_label l _) as b. + cutrewrite (b = false); auto. + subst; unfold is_label. + destruct i; simpl in * |- *; try (destruct (in_dec l nil); intuition). + inversion H. + destruct (in_dec l (l0::nil)) as [H6|H6]; auto. + simpl in H6; intuition try congruence. +Qed. Lemma find_label_at_begin l bh bl: In l (header bh) @@ -286,6 +296,13 @@ Qed. +Lemma find_label_add_label_diff l bh bl: + ~(In l (header bh)) -> + find_label l bl = find_label l (bh::bl). +Proof. + intros. unfold find_label. destruct (is_label l bh) eqn:H0; auto. + rewrite <- is_label_correct_true in H0. tauto. +Qed. Lemma find_label_transcode_preserved: @@ -343,10 +360,36 @@ Proof. destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. * destruct H5; try congruence. exists (l0::h); simpl; intuition. - rewrite find_label_at_begin in H4. + rewrite find_label_at_begin in H4; auto. apply f_equal. inversion H4 as [H5]. clear H4. - (* A FINIR *) - + unfold concat in * |- *. + destruct (trans_code c'); simpl in * |- *; + inversion H5; subst; simpl; auto. + * exists h. + split; eauto. + rewrite (find_label_add_label_diff l bh bl); eauto. + + (* Tr_add_basic *) + intros. + exploit Mach_find_label_split; eauto. + destruct 1 as [(H2&H3)|(H2&H3)]. + rewrite H2 in H. unfold trans_inst in H. congruence. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. + destruct 1 as (h & H4 & H5). + simpl; unfold is_label. + assert ((header (add_basic bi bh))=(header bh)) as H6. auto. + rewrite H6. + destruct (in_dec l (header bh)) as [H7|H7]; simpl in H6. + * rewrite <- H6 in H7; simpl in H7; destruct H7. + * exists h. + split; eauto. + rewrite (find_label_add_label_diff l bh bl); eauto. +Qed. + + +Lemma find_label_add_basic l bh bl: + ~(In l (header bh)) -> + forall bi, find_label l (add_basic bi bh :: bl) = find_label l (bh::bl). Admitted. -- cgit From 7633cb38e0440160acf3f60f7795a19224850eec Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 29 Mar 2019 10:30:46 +0100 Subject: No more Admitted --- mppa_k1c/Asmblockdeps.v | 157 +++++++++++++++++++++++++++++++----------------- 1 file changed, 102 insertions(+), 55 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 500fc504..6f872188 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1731,6 +1731,37 @@ Proof. - simpl in H. inv H. inv MSR. inv MSW. eexists. split; try split. assumption. assumption. Qed. +Theorem forward_simu_par_wio_basic_Stuck 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 -> + parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> + macro_prun Ge (trans_basic bi) sw sr sr = None. +Proof. + intros GENV MSR MSW H0. inv MSR; inv MSW. + unfold parexec_basic_instr in H0. destruct bi; try discriminate. +(* PLoad *) + - destruct i; destruct i. + all: simpl; rewrite H; rewrite (H1 ra); unfold parexec_load in H0; + destruct (eval_offset _ _); auto; destruct (Mem.loadv _ _ _); auto; discriminate. +(* PStore *) + - destruct i; destruct i; + simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); + unfold parexec_store in H0; destruct (eval_offset _ _); auto; destruct (Mem.storev _ _ _); auto; discriminate. +(* Pallocframe *) + - simpl. Simpl. rewrite (H1 SP). rewrite H. destruct (Mem.alloc _ _ _). simpl in H0. + destruct (Mem.store _ _ _ _); try discriminate. reflexivity. +(* Pfreeframe *) + - simpl. Simpl. rewrite (H1 SP). rewrite H. + destruct (Mem.loadv _ _ _); auto. destruct (rsr GPR12); auto. destruct (Mem.free _ _ _ _); auto. + discriminate. +(* Pget *) + - simpl. destruct rs; subst; try discriminate. + all: simpl; auto. + - simpl. destruct rd; subst; try discriminate. + all: simpl; auto. +Qed. + Theorem forward_simu_par_body: forall bdy ge fn rsr mr sr rsw mw sw rs' m', Ge = Genv ge fn -> @@ -1856,20 +1887,52 @@ Proof. intros rr. destruct rr; unfold par_nextblock; Simpl. Qed. -Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). - -(* Lemma put in Parallelizability. -Lemma prun_iw_app_some: - forall c c' sr sw s' s'', - prun_iw Ge c sw sr = Some s' -> - prun_iw Ge c' s' sr = Some s'' -> - prun_iw Ge (c ++ c') sw sr = Some s''. +Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Stuck -> + macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Proof. - induction c. - - simpl. intros. congruence. - - intros. simpl in *. destruct (macro_prun _ _ _ _); auto. eapply IHc; eauto. discriminate. + intros GENV MSR MSW H0. inv MSR; inv MSW. destruct ex as [ctl|]; try discriminate. + destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). +(* Pbuiltin *) + - simpl in *. rewrite (H1 PC). reflexivity. +(* Pj_l *) + - simpl in *. rewrite (H1 PC). unfold goto_label_deps. unfold par_goto_label in H0. + destruct (label_pos _ _ _); auto. simpl in *. unfold par_nextblock in H0. rewrite Pregmap.gss in H0. + destruct (Val.offset_ptr _ _); try discriminate; auto. +(* Pcb *) + - simpl in *. destruct (cmp_for_btest bt). destruct i. + -- destruct o. + + unfold par_eval_branch in H0; unfold eval_branch_deps. + rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. + destruct (Val.cmp_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. + destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. + + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. + -- destruct o. + + unfold par_eval_branch in H0; unfold eval_branch_deps. + rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. + destruct (Val.cmpl_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. + destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. + + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. +(* Pcbu *) + - simpl in *. destruct (cmpu_for_btest bt). destruct i. + -- destruct o. + + unfold par_eval_branch in H0; unfold eval_branch_deps. + rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. + destruct (Val_cmpu_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. + destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. + + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. + -- destruct o. + + unfold par_eval_branch in H0; unfold eval_branch_deps. + rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. + destruct (Val_cmplu_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. + destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. + + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. 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 rs' m': Ge = Genv ge fn -> @@ -1908,41 +1971,6 @@ Proof. erewrite prun_iw_app_Some; eauto. eassumption. Qed. -Lemma trans_body_perserves_permutation bdy1 bdy2: - Permutation bdy1 bdy2 -> - Permutation (trans_body bdy1) (trans_body bdy2). -Proof. - induction 1; simpl; econstructor; eauto. -Qed. - -Lemma trans_body_app bdy1: forall bdy2, - trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). -Proof. - induction bdy1; simpl; congruence. -Qed. - -Theorem trans_block_perserves_permutation bdy1 bdy2 b: - Permutation (bdy1 ++ bdy2) (body b) -> - Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). -Proof. - intro H; unfold trans_block, trans_block_aux. - eapply perm_trans. - - eapply Permutation_app_tail. - apply trans_body_perserves_permutation. - apply Permutation_sym; eapply H. - - rewrite trans_body_app. rewrite <-! app_assoc. - apply Permutation_app_head. - apply Permutation_app_comm. -Qed. - -Lemma forward_simu_par_wio_basic_Stuck 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 -> - parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> - macro_prun Ge (trans_basic bi) sw sr sr = None. -Admitted. - Lemma forward_simu_par_body_Stuck bdy: forall ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> match_states (State rsr mr) sr -> @@ -1962,14 +1990,6 @@ Proof. intros X; simpl; rewrite X; auto. Qed. -Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Stuck -> - macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. -Admitted. - Lemma forward_simu_par_wio_stuck_bdy1 ge fn rs m s1' bdy1 sz ex: Ge = Genv ge fn -> match_states (State rs m) s1' -> @@ -1999,6 +2019,33 @@ Proof. eapply forward_simu_par_body_Stuck. 4: eauto. all: eauto. Qed. +Lemma trans_body_perserves_permutation bdy1 bdy2: + Permutation bdy1 bdy2 -> + Permutation (trans_body bdy1) (trans_body bdy2). +Proof. + induction 1; simpl; econstructor; eauto. +Qed. + +Lemma trans_body_app bdy1: forall bdy2, + trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). +Proof. + induction bdy1; simpl; congruence. +Qed. + +Theorem trans_block_perserves_permutation bdy1 bdy2 b: + Permutation (bdy1 ++ bdy2) (body b) -> + Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). +Proof. + intro H; unfold trans_block, trans_block_aux. + eapply perm_trans. + - eapply Permutation_app_tail. + apply trans_body_perserves_permutation. + apply Permutation_sym; eapply H. + - rewrite trans_body_app. rewrite <-! app_assoc. + apply Permutation_app_head. + apply Permutation_app_comm. +Qed. + Theorem forward_simu_par: forall rs1 m1 s1' b ge fn rs2 m2, Ge = Genv ge fn -> -- cgit From e9a05f4ca3157a88a03f71ab31ef59bd96650142 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 29 Mar 2019 11:30:41 +0100 Subject: Avancement dans la preuve du MBjumptable --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 5d952d02..2a238c7c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1364,7 +1364,27 @@ Proof. all: rewrite <- C; try discriminate; unfold nextblock; Simpl. } intros. discriminate. + (* MBjumptable *) - admit. + 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. 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. + { admit. } + discriminate. + (* MBreturn *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. inv TBC. inv TIC. inv H0. -- cgit From 10462d01d7ed4585cece61f756f12d2978593b1a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 29 Mar 2019 14:54:05 +0100 Subject: Finition de la preuve de Asmblockgenproof --- mppa_k1c/Asmblockgenproof.v | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 2a238c7c..63f4c136 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1383,7 +1383,10 @@ Proof. 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. - { admit. } + { 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. @@ -1419,7 +1422,7 @@ Proof. generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. eapply agree_exten; eauto. intros. Simpl. discriminate. -Admitted. +Qed. Definition mb_remove_first (bb: MB.bblock) := {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. -- cgit From 0dc6f0aadfa95c722324b10c56768900760337a0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 29 Mar 2019 16:11:27 +0100 Subject: Preuve de Jumptable dans Asmblockdeps.v --- mppa_k1c/Asmblockdeps.v | 15 +++++++++++++++ mppa_k1c/Asmvliw.v | 10 +++++++++- 2 files changed, 24 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 7f03c66a..dd876485 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1845,6 +1845,17 @@ Proof. - destruct c; destruct i; try discriminate. all: try (inv H0; inv MSR; inv MSW; eexists; split; [| split]; [simpl; rewrite (H0 PC); reflexivity | Simpl | intros rr; destruct rr; unfold par_nextblock; Simpl]). + (* Pjumptable *) + + simpl in H0. destruct (par_nextblock _ _ _) eqn:PNEXT; try discriminate. + destruct (list_nth_z _ _) eqn:LISTS; try discriminate. unfold par_goto_label in H0. + destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ rsr PC) eqn:NB; try discriminate. inv H0. + inv MSR; inv MSW. eexists; split; try split. + * simpl. rewrite (H0 PC). Simpl. rewrite (H0 r). unfold par_nextblock in PNEXT. rewrite Pregmap.gso in PNEXT; try discriminate. rewrite PNEXT. + rewrite LISTS. unfold goto_label_deps. rewrite LPOS. unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. + * Simpl. + * intros rr; destruct rr; unfold par_nextblock; Simpl. + destruct (preg_eq g GPR62). rewrite e. Simpl. + destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. (* Pj_l *) + simpl in H0. unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ _) eqn:NB; try discriminate. inv H0. inv MSR; inv MSW. @@ -1942,6 +1953,10 @@ Proof. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). (* Pbuiltin *) - simpl in *. rewrite (H1 PC). reflexivity. +(* Pjumptable *) + - simpl in *. rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. + destruct (rsr r); auto. destruct (list_nth_z _ _); auto. unfold par_goto_label in H0. unfold goto_label_deps. + destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); try discriminate; auto. (* Pj_l *) - simpl in *. rewrite (H1 PC). unfold goto_label_deps. unfold par_goto_label in H0. destruct (label_pos _ _ _); auto. simpl in *. unfold par_nextblock in H0. rewrite Pregmap.gss in H0. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index a6e9f04b..d553c612 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -211,6 +211,15 @@ Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) Next (rsw#RA <- (rsr#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw | Picall r => Next (rsw#RA <- (rsr#PC) #PC <- (rsr#r)) mw + | Pjumptable r tbl => + match rsr#r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => par_goto_label f lbl rsr (rsw #GPR62 <- Vundef #GPR63 <- Vundef) mw + end + | _ => Stuck + end | Pgoto s => Next (rsw#PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw | Pigoto r => @@ -230,7 +239,6 @@ Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) | (None, _) => Stuck end - (** Pseudo-instructions *) | Pbuiltin ef args res => Stuck (**r treated specially below *) -- cgit From 3451ed469864c10b2fc5892d46dab08e57e68416 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 30 Mar 2019 16:20:20 +0100 Subject: fix for jump tables --- mppa_k1c/TargetPrinter.ml | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 29e0fef4..6416b65b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -99,6 +99,14 @@ module Target (*: TARGET*) = (* Associate labels to floating-point constants and to symbols. *) + let print_tbl oc (lbl, tbl) = + fprintf oc " .balign 4\n"; + fprintf oc "%a:\n" label lbl; + List.iter + (fun l -> fprintf oc " .4byte %a\n" + print_label l) + tbl + let emit_constants oc lit = if exists_constants () then begin section oc lit; @@ -266,15 +274,18 @@ module Target (*: TARGET*) = fprintf oc " loopdo %a, %a\n" ireg r print_label lbl | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in - jumptables := (lbl, tbl) :: !jumptables; + (* jumptables := (lbl, tbl) :: !jumptables; *) let base_reg = if idx_reg=Asmblock.GPR63 then Asmblock.GPR62 else Asmblock.GPR63 in fprintf oc "%s jumptable [ " comment; List.iter (fun l -> fprintf oc "%a " print_label l) tbl; fprintf oc "]\n"; fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; fprintf oc " lwz.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; - fprintf oc " igoto %a\n ;;\n" ireg base_reg - + fprintf oc " igoto %a\n ;;\n" ireg base_reg; + section oc Section_jumptable; + print_tbl oc (lbl, tbl); + section oc Section_text + (* Load/Store instructions *) | Plb(rd, ra, ofs) -> fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra @@ -523,21 +534,14 @@ module Target (*: TARGET*) = let print_align oc alignment = fprintf oc " .balign %d\n" alignment - - let print_jumptable oc jmptbl = - let print_tbl oc (lbl, tbl) = - fprintf oc "%a:\n" label lbl; - List.iter - (fun l -> fprintf oc " .4byte %a\n" - print_label l) - tbl in - if !jumptables <> [] then + + let print_jumptable oc jmptbl = () + (* if !jumptables <> [] then begin section oc jmptbl; - fprintf oc " .balign 4\n"; List.iter (print_tbl oc) !jumptables; jumptables := [] - end + end *) let print_fun_info = elf_print_fun_info -- cgit From 2cbb81b2679a6d2b25bf490528060b321117294c Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 10:25:41 +0200 Subject: delete useless DepExample* files in order to avoid to keep these files up-to-date here... --- mppa_k1c/abstractbb/DepExample.v | 151 ---------- mppa_k1c/abstractbb/DepExampleDemo.v | 400 --------------------------- mppa_k1c/abstractbb/DepExampleEqTest.v | 334 ---------------------- mppa_k1c/abstractbb/DepExampleParallelTest.v | 166 ----------- 4 files changed, 1051 deletions(-) delete mode 100644 mppa_k1c/abstractbb/DepExample.v delete mode 100644 mppa_k1c/abstractbb/DepExampleDemo.v delete mode 100644 mppa_k1c/abstractbb/DepExampleEqTest.v delete mode 100644 mppa_k1c/abstractbb/DepExampleParallelTest.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/DepExample.v b/mppa_k1c/abstractbb/DepExample.v deleted file mode 100644 index a239e24f..00000000 --- a/mppa_k1c/abstractbb/DepExample.v +++ /dev/null @@ -1,151 +0,0 @@ -(** Specification of the example illustrating how to use ImpDep. *) - -Require Export ZArith. - -Require Export ZArith. -Require Export List. -Export ListNotations. - -(* Syntax *) - -Definition reg := positive. - -Inductive operand := - | Imm (i:Z) - | Reg (r:reg) - . - -Inductive arith_op := ADD | SUB | MUL. - -Inductive inst := - | MOVE (dest: reg) (src: operand) - | ARITH (dest: reg) (op: arith_op) (src1 src2: operand) - | LOAD (dest base: reg) (offset: operand) - | STORE (src base: reg) (offset: operand) - | MEMSWAP (r base: reg) (offset: operand) - . - -Definition bblock := list inst. - -(* Semantics *) - -Definition value := Z. - -Definition addr := positive. - -Definition mem := addr -> value. - -Definition assign (m: mem) (x:addr) (v: value) := - fun y => if Pos.eq_dec x y then v else (m y). - -Definition regmem := reg -> value. - -Record state := { sm: mem; rm: regmem }. - -Definition operand_eval (x: operand) (rm: regmem): value := - match x with - | Imm i => i - | Reg r => rm r - end. - -Definition arith_op_eval (o: arith_op): value -> value -> value := - match o with - | ADD => Z.add - | SUB => Z.sub - | MUL => Z.mul - end. - -Definition get_addr (base:reg) (offset:operand) (rm: regmem): option addr := - let b := rm base in - let ofs := operand_eval offset rm in - match Z.add b ofs with - | Zpos p => Some p - | _ => None - end. - -(* two-state semantics -- dissociating read from write access. - - all read access on [sin] state - - all register write access modifies [sout] state - - all memory write access modifies [sin] state - => useful for parallel semantics - NB: in this parallel semantics -- there is at most one STORE by bundle - which is non-deterministically chosen... -*) -Definition sem_inst (i: inst) (sin sout: state): option state := - match i with - | MOVE dest src => - let v := operand_eval src (rm sin) in - Some {| sm := sm sout; - rm := assign (rm sout) dest v |} - | ARITH dest op src1 src2 => - let v1 := operand_eval src1 (rm sin) in - let v2 := operand_eval src2 (rm sin) in - let v := arith_op_eval op v1 v2 in - Some {| sm := sm sout; - rm := assign (rm sout) dest v |} - | LOAD dest base offset => - match get_addr base offset (rm sin) with - | Some srce => - Some {| sm := sm sout; - rm := assign (rm sout) dest (sm sin srce) |} - | None => None - end - | STORE srce base offset => - match get_addr base offset (rm sin) with - | Some dest => - Some {| sm := assign (sm sin) dest (rm sin srce); - rm := rm sout |} - | None => None - end - | MEMSWAP x base offset => - match get_addr base offset (rm sin) with - | Some ad => - Some {| sm := assign (sm sin) ad (rm sin x); - rm := assign (rm sout) x (sm sin ad) |} - | None => None - end - end. - -Local Open Scope list_scope. - -(** usual sequential semantics *) -Fixpoint sem_bblock (p: bblock) (s: state): option state := - match p with - | nil => Some s - | i::p' => - match sem_inst i s s with - | Some s' => sem_bblock p' s' - | None => None - end - end. - -Definition state_equiv (s1 s2: state): Prop := - (forall x, sm s1 x = sm s2 x) /\ - (forall x, rm s1 x = rm s2 x). - -(* equalities on bblockram outputs *) -Definition res_equiv (os1 os2: option state): Prop := - match os1 with - | Some s1 => exists s2, os2 = Some s2 /\ state_equiv s1 s2 - | None => os2 = None - end. - - -Definition bblock_equiv (p1 p2: bblock): Prop := - forall s, res_equiv (sem_bblock p1 s) (sem_bblock p2 s). - -(** parallel semantics with in-order writes *) -Fixpoint sem_bblock_par_iw (p: bblock) (sin sout: state): option state := - match p with - | nil => Some sout - | i::p' => - match sem_inst i sin sout with - | Some sout' => sem_bblock_par_iw p' sin sout' - | None => None - end - end. - -(** parallelism semantics with arbitrary order writes *) -Require Import Sorting.Permutation. - -Definition sem_bblock_par (p: bblock) (sin: state) (sout: option state) := exists p', res_equiv sout (sem_bblock_par_iw p' sin sin) /\ Permutation p p'. diff --git a/mppa_k1c/abstractbb/DepExampleDemo.v b/mppa_k1c/abstractbb/DepExampleDemo.v deleted file mode 100644 index 74e8f35e..00000000 --- a/mppa_k1c/abstractbb/DepExampleDemo.v +++ /dev/null @@ -1,400 +0,0 @@ -(** Demo of the example illustrating how to use ImpDep. *) - -Require Import DepExampleEqTest. -Require Import Bool. - -Open Scope Z_scope. - -Module EqTests. - -Section TESTS. - -Variable ge: P.genv. - -(**** TESTS DRIVER ! ****) - -Record test_input := { - name: pstring; - expected: bool; - verbose: bool; - p1: bblock; - p2: bblock; -}. - -Definition run1 (t: test_input): ?? unit := - print ((name t) +; " =>");; - DO result <~ bblock_eq_test ge (verbose t) (p1 t) (p2 t);; - assert_b (eqb result (expected t)) "UNEXPECTED RESULT";; - if expected t - then println " SUCCESS" - else RET tt (* NB: in this case - bblock_eq_test is expected to have print an ERROR mesg *) - . - -Local Hint Resolve eqb_prop. - -Lemma run1_correctness (t: test_input): - WHEN run1 t ~> _ THEN (expected t)=true -> bblock_equiv (p1 t) (p2 t). -Proof. - unfold run1; destruct t; simpl; wlp_simplify; subst. -Qed. -Global Opaque run1. -Hint Resolve run1_correctness: wlp. - -Fixpoint run_all (l: list test_input): ?? unit := - match l with - | nil => RET tt - | t::l' => - println "" ;; (* SOME SPACES ! *) - run1 t;; - run_all l' - end. - -Lemma run_all_correctness l: - WHEN run_all l ~> _ THEN (forall t, List.In t l -> (expected t)=true -> bblock_equiv (p1 t) (p2 t)). -Proof. - induction l; simpl; wlp_simplify; subst; auto. -Qed. -Global Opaque run_all. - -(**** TESTS ****) - -Definition move (dst src: reg) := MOVE dst (Reg src). -Definition add_imm (dst src: reg) (z:Z) := ARITH dst ADD (Reg src) (Imm z). -Definition incr (r: reg) (z:Z) := add_imm r r z. -Definition add (dst src1 src2: reg) := ARITH dst ADD (Reg src1) (Reg src2). - -Definition load (dst src:reg) (ofs:Z) := LOAD dst src (Imm ofs). -Definition store (src dst:reg) (ofs:Z) := STORE src dst (Imm ofs). -Definition memswap (r base:reg) (ofs:Z) := MEMSWAP r base (Imm ofs). - -Definition R1: reg := 1%positive. -Definition R2: reg := 2%positive. -Definition R3: reg := 3%positive. -Definition R4: reg := 4%positive. - - -Definition demo: ?? unit := run_all [ - - {| name:="move_ok" ; - expected:=true; - verbose:=true; - p1:=[ move R2 R1; move R3 R1 ]; - p2:=[ move R3 R1; move R2 R3 ]; - |} ; - {| name:="move_ko" ; - expected:=false; - verbose:=true; - p1:=[ move R2 R1; move R3 R1 ]; - p2:=[ move R3 R1 ]; - |} ; - - {| name:="add_load_RAR_ok" ; - expected:=true; - verbose:=true; - p1:=[ add_imm R1 R2 5; move R4 R2; load R3 R2 2 ]; - p2:=[ load R3 R2 2; add_imm R1 R2 5; move R4 R2 ]; |} ; - - {| name:="add_load_RAW_ko"; - expected:=false; - verbose:=true; - p1:=[ add_imm R1 R2 5; move R4 R2; load R3 R1 2 ]; - p2:=[ load R3 R1 2; add_imm R1 R2 5; move R4 R2 ]; |} ; - - {| name:="add_load_WAW_ko"; - expected:=false; - verbose:=true; - p1:=[ add_imm R3 R2 5; move R4 R2; load R3 R1 2 ]; - p2:=[ load R3 R1 2; add_imm R3 R2 5; move R4 R2 ]; |} ; - - {| name:="memswap_ok1"; - expected:=true; - verbose:=true; - p1:=[ add_imm R1 R2 5; memswap R3 R2 2 ]; - p2:=[ memswap R3 R2 2; add_imm R1 R2 5 ]; |} ; - - {| name:="memswap_ok2" ; - expected:=true; - verbose:=true; - p1:=[ load R1 R2 2; store R3 R2 2; move R3 R1]; - p2:=[ memswap R3 R2 2 ; move R1 R3 ]; - |} ; - - {| name:="memswap_ko" ; - expected:=false; - verbose:=true; - p1:=[ load R3 R2 2; store R3 R2 2]; - p2:=[ memswap R3 R2 2 ]; - |} -]. - - -Fixpoint repeat_aux (n:nat) (rev_body next: bblock): bblock := - match n with - | O => next - | (S n) => repeat_aux n rev_body (List.rev_append rev_body next) - end. - -Definition repeat n body next := repeat_aux n (List.rev_append body []) next. - - -Definition inst1 := add R1 R1 R2. - -(* NB: returns [inst1^10; next] *) -Definition dummy1 next:= repeat 10%nat [inst1] next. - -Definition main: ?? unit := run_all [ - - {| name:="move_never_skips1" ; - expected:=false; - verbose:=false; - p1:=[ move R2 R2 ]; - p2:=[ ]; - |} ; - - {| name:="move_compress_ok" ; - expected:=true; - verbose:=false; - p1:=[ move R1 R2; move R2 R1; MOVE R1 (Imm 7) ]; - p2:=[ MOVE R1 (Imm 7); move R2 R2 ]; - |} ; - - {| name:="move_never_skip2" ; - expected:=false; - verbose:=false; - p1:=[ move R1 R2; move R2 R1; MOVE R1 (Imm 7) ]; - p2:=[ MOVE R1 (Imm 7) ]; - |} ; - - {| name:="R2_RAR_ok1"; - expected:=true; - verbose:=false; - p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; - p2:=load R3 R2 2::store R3 R4 7::(dummy1 nil) |} ; - {| name:="R2_RAR_ok2"; - expected:=true; - verbose:=false; - p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; - p2:=load R3 R2 2::(dummy1 [store R3 R4 7]) |} ; - {| name:="R2_RAR_ok3"; - expected:=true; - verbose:=false; - p1:=dummy1 [ load R3 R2 2; store R3 R4 7 ]; - p2:=load R3 R2 2::(repeat 4%nat [inst1;inst1] [store R3 R4 7; inst1; inst1]) |} ; - {| name:="bad_register_name_ko"; - expected:=false; - verbose:=false; - p1:=dummy1 [ load R3 R2 2 ]; - p2:=dummy1 [ load R3 R3 2 ] |} ; - {| name:="bad_instruction_ko"; - expected:=false; - verbose:=false; - p1:=dummy1 [ load R3 R2 2 ]; - p2:=dummy1 [ store R3 R2 2 ] |} ; - {| name:="incompleteness_ko"; - expected:=false; - verbose:=false; - p1:=dummy1 [ load R3 R2 2 ]; - p2:=[inst1; load R3 R2 2] |} ; - - - {| name:="R2_WAR_ko"; - expected:=false; - verbose:=false; - p1:=dummy1 [ load R2 R3 2 ]; - p2:=load R2 R3 2::(dummy1 nil) |} ; - {| name:="bad_register_name_ko2"; - expected:=false; - verbose:=false; - p1:=dummy1 [ load R2 R3 2 ]; - p2:=load R3 R2 2::(dummy1 nil) |} ; - - - {| name:="load_RAR_ok1"; - expected:=true; - verbose:=false; - p1:=[ load R1 R2 2; load R3 R4 5]; - p2:=[ load R3 R4 5; load R1 R2 2]; |} ; - {| name:="load_RAR_ok2"; - expected:=true; - verbose:=false; - p1:=[ load R1 R2 2; load R3 R2 5]; - p2:=[ load R3 R2 5; load R1 R2 2]; |} ; - {| name:="load_WAW_ko"; - expected:=false; - verbose:=false; - p1:=[ load R1 R2 2; load R1 R4 5]; - p2:=[ load R1 R4 5; load R1 R2 2]; |} ; - {| name:="load_store_WAR_ko"; - expected:=false; - verbose:=false; - p1:=[ load R1 R2 2; store R3 R4 5]; - p2:=[ store R3 R4 5; load R1 R2 2]; |} - - ]. - -Definition incr_R1_5 := incr R1 5. -Definition incr_R2_3 := incr R2 3. - -Definition big_test (bigN:nat) (name: pstring): ?? unit := - println "";; - println("---- Time of bigtest " +; name);; - timer(run_all, [ - - {| name:="big_test_ok1"; - expected:=true; - verbose:=false; - p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; - p2:=repeat bigN [incr_R1_5] (repeat (S bigN) [incr_R2_3] nil) |} ; - {| name:="big_test_ok2"; - expected:=true; - verbose:=false; - p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; - p2:=repeat bigN [incr_R2_3;incr_R1_5] [incr_R2_3] |} ; - {| name:="big_test_ok3"; - expected:=true; - verbose:=false; - p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; - p2:=repeat (S bigN) [incr_R2_3] (repeat bigN [incr_R1_5] nil) |} ; - {| name:="big_test_ko1"; - expected:=false; - verbose:=false; - p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; - p2:=repeat bigN [incr_R1_5] (repeat bigN [incr_R2_3] nil) |} ; - {| name:="big_test_ko2"; - expected:=false; - verbose:=false; - p1:=repeat bigN [incr_R1_5;incr_R2_3] [incr_R2_3]; - p2:=repeat (S bigN) [incr_R1_5] (repeat bigN [incr_R2_3] nil) |} - - ]). - -Fixpoint big_tests (l:list (nat * string)) := - match l with - | nil => RET tt - | (x,s)::l' => big_test x s;; big_tests l' - end. - -Local Open Scope nat_scope. -Local Open Scope string_scope. - -Definition big_runs: ?? unit := - big_tests [(2500, "2500"); (5000, "5000"); (10000, "10000"); (20000, "20000")]. - - -End EqTests. - - -Require Import DepExampleParallelTest. - -Module ParaTests. - - -(**** TESTS DRIVER ! ****) - -Record test_input := { - name: pstring; - expected: bool; - bundle: bblock; -}. - -Definition run1 (t: test_input): ?? unit := - print ((name t) +; " =>");; - assert_b (eqb (bblock_is_para (bundle t)) (expected t)) "UNEXPECTED RESULT";; - if expected t - then println " SUCCESS" - else println " FAILED (as expected)" - . - -Local Hint Resolve eqb_prop. - -Definition correct_bundle p := forall s os', (sem_bblock_par p s os' <-> res_equiv os' (sem_bblock p s)). - -Lemma run1_correctness (t: test_input): - WHEN run1 t ~> _ THEN (expected t)=true -> correct_bundle (bundle t). -Proof. - unfold run1; destruct t; simpl; wlp_simplify; subst. - - unfold correct_bundle; intros; apply bblock_is_para_correct; auto. - - discriminate. -Qed. -Global Opaque run1. -Hint Resolve run1_correctness: wlp. - -Fixpoint run_all (l: list test_input): ?? unit := - match l with - | nil => RET tt - | t::l' => - run1 t;; - run_all l' - end. - -Lemma run_all_correctness l: - WHEN run_all l ~> _ THEN (forall t, List.In t l -> (expected t)=true -> correct_bundle (bundle t)). -Proof. - induction l; simpl; wlp_simplify; subst; auto. -Qed. -Global Opaque run_all. - -(**** TESTS ****) - -Definition add_imm (dst src: reg) (z:Z) := ARITH dst ADD (Reg src) (Imm z). - -Definition load (dst src:reg) (ofs:Z) := LOAD dst src (Imm ofs). -Definition store (src dst:reg) (ofs:Z) := STORE src dst (Imm ofs). -Definition memswap (r base:reg) (ofs:Z) := MEMSWAP r base (Imm ofs). - -Definition R1: reg := 1%positive. -Definition R2: reg := 2%positive. -Definition R3: reg := 3%positive. -Definition R4: reg := 4%positive. -Definition R5: reg := 5%positive. -Definition R6: reg := 5%positive. - - -Definition main: ?? unit := - println "";; - println "-- Parallel Checks --";; - run_all [ - {| name:="test_war_ok"; - expected:=true; - bundle:=[add_imm R1 R2 2;add_imm R2 R2 3] - |}; - {| name:="test_raw_ko"; - expected:=false; - bundle:=[add_imm R1 R2 2;add_imm R2 R1 3] - |}; - {| name:="test_waw_ko"; - expected:=false; - bundle:=[add_imm R1 R2 2;add_imm R1 R2 3] - |}; - {| name:="test_war_load_store_ok"; - expected:=true; - bundle:=[load R1 R2 2;load R2 R3 3; store R3 R4 4] - |}; - {| name:="test_raw_load_store_ko"; - expected:=false; - bundle:=[load R1 R2 2;store R5 R4 4;load R2 R3 3] - |}; - {| name:="test_waw_load_store_ko"; - expected:=false; - bundle:=[load R1 R2 2;store R3 R2 3;store R5 R4 4] - |}; - {| name:="test_arith_load_store_ok"; - expected:=true; - bundle:=[load R1 R2 2; add_imm R2 R4 3; load R3 R6 3; add_imm R4 R4 3; store R6 R5 4; add_imm R6 R6 7] - |} - ]. - -End ParaTests. - -(*************************) -(* Extraction directives *) - -Require Import ExtrOcamlString. -Require Import ExtrOcamlBasic. - -Import ImpConfig. - -Extraction Blacklist List String. - -Separate Extraction BinIntDef EqTests ParaTests. - diff --git a/mppa_k1c/abstractbb/DepExampleEqTest.v b/mppa_k1c/abstractbb/DepExampleEqTest.v deleted file mode 100644 index a633ee07..00000000 --- a/mppa_k1c/abstractbb/DepExampleEqTest.v +++ /dev/null @@ -1,334 +0,0 @@ -(** Implementation of the example illustrating how to use ImpDep. *) - -Require Export DepExample. -Require Export Impure.ImpIO. -Export Notations. - -Require Import ImpDep. - -Open Scope impure. - -Module P<: ImpParam. - -Module R := Pos. - -Definition genv := unit. - -Section IMP. - -Inductive value_wrap := - | Std (v:value) (* value = DepExample.value *) - | Mem (m:mem) - . - -Inductive op_wrap := - (* constants *) - | Imm (i:Z) - (* arithmetic operation *) - | ARITH (op: arith_op) - | LOAD - | STORE - . - -Definition op_eval (ge: genv) (op: op_wrap) (l:list value_wrap): option value_wrap := - match op, l with - | Imm i, [] => Some (Std i) - | ARITH op, [Std v1; Std v2] => Some (Std (arith_op_eval op v1 v2)) - | LOAD, [Mem m; Std base; Std offset] => - match (Z.add base offset) with - | Zpos srce => Some (Std (m srce)) - | _ => None - end - | STORE, [Mem m; Std srce; Std base; Std offset] => - match (Z.add base offset) with - | Zpos dest => Some (Mem (assign m dest srce)) - | _ => None - end - | _, _ => None - end. - - -Definition value:=value_wrap. -Definition op:=op_wrap. - -Definition op_eq (o1 o2: op_wrap): ?? bool := - match o1, o2 with - | Imm i1, Imm i2 => phys_eq i1 i2 - | ARITH o1, ARITH o2 => phys_eq o1 o2 - | LOAD, LOAD => RET true - | STORE, STORE => RET true - | _, _ => RET false - end. - -Lemma op_eq_correct o1 o2: - WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. -Proof. - destruct o1, o2; wlp_simplify; congruence. -Qed. - -End IMP. -End P. - - -Module L <: ISeqLanguage with Module LP:=P. - -Module LP:=P. - -Include MkSeqLanguage P. - -End L. - - -Module IDT := ImpDepTree L ImpPosDict. - -Section SECT. -Variable ge: P.genv. - -(** Compilation from DepExample to L *) - -Definition the_mem: P.R.t := 1. -Definition reg_map (r: reg): P.R.t := Pos.succ r. - -Coercion L.Name: P.R.t >-> L.exp. - -Definition comp_op (o:operand): L.exp := - match o with - | Imm i => L.Op (P.Imm i) L.Enil - | Reg r => reg_map r - end. - -Definition comp_inst (i: inst): L.macro := - match i with - | MOVE dest src => - [ (reg_map dest, (comp_op src)) ] - | ARITH dest op src1 src2 => - [ (reg_map dest, L.Op (P.ARITH op) (L.Econs (comp_op src1) (L.Econs (comp_op src2) L.Enil))) ] - | LOAD dest base offset => - [ (reg_map dest, L.Op P.LOAD (L.Econs the_mem (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))) ] - | STORE srce base offset => - [ (the_mem, L.Op P.STORE (L.Econs the_mem (L.Econs (reg_map srce) (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil))))) ] - | MEMSWAP x base offset => - [ (reg_map x, L.Op P.LOAD (L.Econs the_mem (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))); - (the_mem, L.Old (L.Op P.STORE (L.Econs the_mem (L.Econs (reg_map x) (L.Econs (reg_map base) (L.Econs (comp_op offset) L.Enil)))))) ] - end. - -Fixpoint comp_bblock (p: bblock): L.bblock := - match p with - | nil => nil - | i::p' => (comp_inst i)::(comp_bblock p') - end. - -(** Correctness proof of the compiler *) - -Lemma the_mem_separation: forall r, reg_map r <> the_mem. -Proof. - intros r; apply Pos.succ_not_1. -Qed. - -Lemma reg_map_separation: forall r1 r2, r1 <> r2 -> reg_map r1 <> reg_map r2. -Proof. - unfold reg_map; intros r1 r2 H1 H2; lapply (Pos.succ_inj r1 r2); auto. -Qed. - -Local Hint Resolve the_mem_separation reg_map_separation. - -Definition match_state (s: state) (m:L.mem): Prop := - m the_mem = P.Mem (sm s) /\ forall r, m (reg_map r) = P.Std (rm s r). - -Definition trans_state (s: state): L.mem := - fun x => - if Pos.eq_dec x the_mem - then P.Mem (sm s) - else P.Std (rm s (Pos.pred x)). - -Lemma match_trans_state (s:state): match_state s (trans_state s). -Proof. - unfold trans_state; constructor 1. - - destruct (Pos.eq_dec the_mem the_mem); try congruence. - - intros r; destruct (Pos.eq_dec (reg_map r) the_mem). - * generalize the_mem_separation; subst; congruence. - * unfold reg_map; rewrite Pos.pred_succ. auto. -Qed. - -Definition match_option_state (os: option state) (om:option L.mem): Prop := - match os with - | Some s => exists m, om = Some m /\ match_state s m - | None => om = None - end. - -Lemma comp_op_correct o s m old: match_state s m -> L.exp_eval ge (comp_op o) m old = Some (P.Std (operand_eval o (rm s))). -Proof. - destruct 1 as [H1 H2]; destruct o; simpl; auto. - rewrite H2; auto. -Qed. - -Lemma comp_bblock_correct_aux p: forall s m, match_state s m -> match_option_state (sem_bblock p s) (L.run ge (comp_bblock p) m). -Proof. - induction p as [| i p IHp]; simpl; eauto. - intros s m H; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. - - (* MOVE *) - apply IHp. - destruct H as [H1 H2]; constructor 1; simpl. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* ARITH *) - apply IHp. - destruct H as [H1 H2]; constructor 1; simpl. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* LOAD *) - destruct H as [H1 H2]. - rewrite H1, H2; simpl. - unfold get_addr. - destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. - apply IHp. - constructor 1; simpl. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* STORE *) - destruct H as [H1 H2]. - rewrite H1, !H2; simpl. - unfold get_addr. - destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. - apply IHp. - constructor 1; simpl; auto. - + intros r; rewrite L.assign_diff; auto. - - (* MEMSWAP *) - destruct H as [H1 H2]. - rewrite H1, !H2; simpl. - unfold get_addr. - destruct (rm s base + operand_eval offset (rm s))%Z; simpl; auto. - apply IHp. - constructor 1; simpl; auto. - intros r0; rewrite L.assign_diff; auto. - unfold assign; destruct (Pos.eq_dec r r0). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. -Qed. - -Lemma comp_bblock_correct p s: match_option_state (sem_bblock p s) (L.run ge (comp_bblock p) (trans_state s)). -Proof. - eapply comp_bblock_correct_aux. apply match_trans_state. -Qed. - -Lemma state_equiv_from_match (s1 s2: state) (m: L.mem) : - (match_state s1 m) -> (match_state s2 m) -> (state_equiv s1 s2). -Proof. - unfold state_equiv, match_state. intuition. - - congruence. - - assert (P.Std (rm s1 x) = P.Std (rm s2 x)); congruence. -Qed. - -Definition match_option_stateX (om:option L.mem) (os:option state): Prop := - match om with - | Some m => exists s, os = Some s /\ match_state s m - | None => os = None - end. - -Local Hint Resolve state_equiv_from_match. - -Lemma res_equiv_from_match (os1 os2: option state) (om: option L.mem): - (match_option_state os1 om) -> (match_option_stateX om os2) -> (res_equiv os1 os2). -Proof. - destruct os1 as [s1|]; simpl. - - intros [m [H1 H2]]; subst; simpl. - intros [s2 [H3 H4]]; subst; simpl. - eapply ex_intro; intuition eauto. - - intro; subst; simpl; auto. -Qed. - - -Lemma match_option_state_intro_X om os: match_option_state os om -> match_option_stateX om os. -Proof. - destruct os as [s | ]; simpl. - - intros [m [H1 H2]]. subst; simpl. eapply ex_intro; intuition eauto. - - intros; subst; simpl; auto. -Qed. - - -Lemma match_from_res_eq om1 om2 os: - L.res_eq om2 om1 -> match_option_stateX om1 os -> match_option_stateX om2 os. -Proof. - destruct om2 as [m2 | ]; simpl. - - intros [m [H1 H2]]. subst; simpl. - intros [s [H3 H4]]; subst; simpl. - eapply ex_intro; intuition eauto. - unfold match_state in * |- *. - intuition (rewrite H2; auto). - - intros; subst; simpl; auto. -Qed. - -Lemma bblock_equiv_reduce p1 p2: L.bblock_equiv ge (comp_bblock p1) (comp_bblock p2) -> bblock_equiv p1 p2. -Proof. - unfold L.bblock_equiv, bblock_equiv. - intros; eapply res_equiv_from_match. - apply comp_bblock_correct. - eapply match_from_res_eq. eauto. - apply match_option_state_intro_X. - apply comp_bblock_correct. -Qed. - - - - -(* NB: pretty-printing functions below only mandatory for IDT.verb_bblock_eq_test *) -Local Open Scope string_scope. - -Definition string_of_name (x: P.R.t): ?? pstring := - match x with - | xH => RET (Str ("the_mem")) - | _ as x => - DO s <~ string_of_Z (Zpos (Pos.pred x)) ;; - RET ("R" +; s) - end. - -Definition string_of_op (op: P.op): ?? pstring := - match op with - | P.Imm i => - DO s <~ string_of_Z i ;; - RET s - | P.ARITH ADD => RET (Str "ADD") - | P.ARITH SUB => RET (Str "SUB") - | P.ARITH MUL => RET (Str "MUL") - | P.LOAD => RET (Str "LOAD") - | P.STORE => RET (Str "STORE") - end. - -Definition bblock_eq_test (verb: bool) (p1 p2: bblock) : ?? bool := - if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op ge (comp_bblock p1) (comp_bblock p2) - else - IDT.bblock_eq_test ge (comp_bblock p1) (comp_bblock p2). - -Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. - - -Theorem bblock_eq_test_correct verb p1 p2 : - WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> bblock_equiv p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque bblock_eq_test. -Hint Resolve bblock_eq_test_correct: wlp. - -End SECT. -(* TEST: we can coerce this bblock_eq_test into a pure function (even if this is a little unsafe). *) -(* -Import UnsafeImpure. - -Definition pure_eq_test v (p1 p2: bblock) : bool := unsafe_coerce (bblock_eq_test v p1 p2). - -Theorem pure_eq_test_correct v p1 p2 : - pure_eq_test v p1 p2 = true -> bblock_equiv p1 p2. -Proof. - unfold pure_eq_test. intros; eapply bblock_eq_test_correct. - - apply unsafe_coerce_not_really_correct; eauto. - - eauto. -Qed. -*) \ No newline at end of file diff --git a/mppa_k1c/abstractbb/DepExampleParallelTest.v b/mppa_k1c/abstractbb/DepExampleParallelTest.v deleted file mode 100644 index 35b44683..00000000 --- a/mppa_k1c/abstractbb/DepExampleParallelTest.v +++ /dev/null @@ -1,166 +0,0 @@ -Require Import DepExampleEqTest. -Require Import Parallelizability. - -Module PChk := ParallelChecks L PosResourceSet. - -Definition bblock_is_para (p: bblock) : bool := - PChk.is_parallelizable (comp_bblock p). - -Local Hint Resolve the_mem_separation reg_map_separation. - -Section SEC. -Variable ge: P.genv. - -(* Actually, almost the same proof script than [comp_bblock_correct_aux] ! - We could definitely factorize the proof through a lemma on compilation to macros. -*) -Lemma comp_bblock_correct_para_iw p: forall sin sout min mout, - match_state sin min -> - match_state sout mout -> - match_option_state (sem_bblock_par_iw p sin sout) (PChk.prun_iw ge (comp_bblock p) mout min). -Proof. - induction p as [|i p IHp]; simpl; eauto. - intros sin sout min mout Hin Hout; destruct i; simpl; erewrite !comp_op_correct; eauto; simpl. - - (* MOVE *) - apply IHp; auto. - destruct Hin as [H1 H2]; destruct Hout as [H3 H4]; constructor 1; simpl; auto. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* ARITH *) - apply IHp; auto. - destruct Hin as [H1 H2]; destruct Hout as [H3 H4]; constructor 1; simpl; auto. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* LOAD *) - destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. - rewrite H1, H2; simpl. - unfold get_addr. - destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. - apply IHp. { constructor 1; auto. } - constructor 1; simpl. - + rewrite L.assign_diff; auto. - + unfold assign; intros r; destruct (Pos.eq_dec dest r). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. - - (* STORE *) - destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. - rewrite H1, !H2; simpl. - unfold get_addr. - destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. - apply IHp. { constructor 1; auto. } - constructor 1; simpl; auto. - intros r; rewrite L.assign_diff; auto. - - (* MEMSWAP *) - destruct Hin as [H1 H2]; destruct Hout as [H3 H4]. - rewrite H1, !H2; simpl. - unfold get_addr. - destruct (rm sin base + operand_eval offset (rm sin))%Z; simpl; auto. - apply IHp. { constructor 1; auto. } - constructor 1; simpl; auto. - + intros r0; rewrite L.assign_diff; auto. - unfold assign; destruct (Pos.eq_dec r r0). - * subst; rewrite L.assign_eq; auto. - * rewrite L.assign_diff; auto. -Qed. - -Local Hint Resolve match_trans_state. - -Definition trans_option_state (os: option state): option L.mem := - match os with - | Some s => Some (trans_state s) - | None => None - end. - -Lemma match_trans_option_state os: match_option_state os (trans_option_state os). -Proof. - destruct os; simpl; eauto. -Qed. - -Local Hint Resolve match_trans_option_state comp_bblock_correct match_option_state_intro_X match_from_res_eq res_equiv_from_match. - -Lemma is_mem_reg (x: P.R.t): x=the_mem \/ exists r, x=reg_map r. -Proof. - case (Pos.eq_dec x the_mem); auto. - unfold the_mem, reg_map; constructor 2. - eexists (Pos.pred x). rewrite Pos.succ_pred; auto. -Qed. - -Lemma res_eq_from_match (os: option state) (om1 om2: option L.mem): - (match_option_stateX om1 os) -> (match_option_state os om2) -> (L.res_eq om1 om2). -Proof. - destruct om1 as [m1|]; simpl. - - intros (s & H1 & H2 & H3); subst; simpl. - intros (m2 & H4 & H5 & H6); subst; simpl. - eapply ex_intro; intuition eauto. - destruct (is_mem_reg x) as [H|(r & H)]; subst; congruence. - - intro; subst; simpl; auto. -Qed. - -(* We use axiom of functional extensionality ! *) -Require Coq.Logic.FunctionalExtensionality. - -Lemma match_from_res_equiv os1 os2 om: - res_equiv os2 os1 -> match_option_state os1 om -> match_option_state os2 om. -Proof. - destruct os2 as [s2 | ]; simpl. - - intros (s & H1 & H2 & H3). subst; simpl. - intros (m & H4 & H5 & H6); subst; simpl. - eapply ex_intro; intuition eauto. - constructor 1. - + rewrite H5; apply f_equal; eapply FunctionalExtensionality.functional_extensionality; auto. - + congruence. - - intros; subst; simpl; auto. -Qed. - - -Require Import Sorting.Permutation. - -Local Hint Constructors Permutation. - -Lemma comp_bblock_Permutation p p': Permutation p p' -> Permutation (comp_bblock p) (comp_bblock p'). -Proof. - induction 1; simpl; eauto. -Qed. - -Lemma comp_bblock_Permutation_back p1 p1': Permutation p1 p1' -> - forall p, p1=comp_bblock p -> - exists p', p1'=comp_bblock p' /\ Permutation p p'. -Proof. - induction 1; simpl; eauto. - - destruct p as [|i p]; simpl; intro X; inversion X; subst. - destruct (IHPermutation p) as (p' & H1 & H2); subst; auto. - eexists (i::p'). simpl; eauto. - - destruct p as [|i1 p]; simpl; intro X; inversion X as [(H & H1)]; subst; clear X. - destruct p as [|i2 p]; simpl; inversion_clear H1. - eexists (i2::i1::p). simpl; eauto. - - intros p H1; destruct (IHPermutation1 p) as (p' & H2 & H3); subst; auto. - destruct (IHPermutation2 p') as (p'' & H4 & H5); subst; eauto. -Qed. - -Local Hint Resolve comp_bblock_Permutation res_eq_from_match match_from_res_equiv comp_bblock_correct_para_iw. - -Lemma bblock_par_iff_prun p s os': - sem_bblock_par p s os' <-> PChk.prun ge (comp_bblock p) (trans_state s) (trans_option_state os'). -Proof. - unfold sem_bblock_par, PChk.prun. constructor 1. - - intros (p' & H1 & H2). - eexists (comp_bblock p'); intuition eauto. - - intros (p' & H1 & H2). - destruct (comp_bblock_Permutation_back _ _ H2 p) as (p0 & H3 & H4); subst; auto. - eexists p0; constructor 1; eauto. -Qed. - -Theorem bblock_is_para_correct p: - bblock_is_para p = true -> forall s os', (sem_bblock_par p s os' <-> res_equiv os' (sem_bblock p s)). -Proof. - intros H; generalize (PChk.is_parallelizable_correct ge _ H); clear H. - intros H s os'. - rewrite bblock_par_iff_prun, H. - constructor; eauto. -Qed. - -End SEC. \ No newline at end of file -- cgit From 1036dcaa7a99870aa1859a9a1c683ad8f9b3b0d8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 1 Apr 2019 12:20:11 +0200 Subject: Using fixedd.rz in longofsingle instead of i64_dtos --- mppa_k1c/SelectLong.vp | 5 ++--- mppa_k1c/SelectLongproof.v | 16 +++++++++++----- 2 files changed, 13 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 0c3618d7..31112dca 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -364,10 +364,9 @@ Definition floatoflongu (e: expr) := if Archi.splitlong then SplitLong.floatoflongu e else Eop Ofloatoflongu (e:::Enil). -(* SplitLong.longofsingle splits the operation into (longoffloat (floatofsingle e)) *) -Definition longofsingle (e: expr) := SplitLong.longofsingle e. +Definition longofsingle (e: expr) := longoffloat (floatofsingle e). -Definition longuofsingle (e: expr) := SplitLong.longuofsingle e. +Definition longuofsingle (e: expr) := longuoffloat (floatofsingle e). Definition singleoflong (e: expr) := SplitLong.singleoflong e. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 79187338..51b989d6 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -600,16 +600,22 @@ Qed. Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. Proof. - unfold longofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) - eapply SplitLongproof.eval_longofsingle; eauto. -(* TrivialExists. *) + unfold longofsingle; red; intros. + destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2. + exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. + apply Float32.to_long_double in EQ. + eapply eval_longoffloat; eauto. simpl. + change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. Qed. Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. Proof. unfold longuofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) - eapply SplitLongproof.eval_longuofsingle; eauto. -(* TrivialExists. *) + destruct x; simpl in H0; inv H0. destruct (Float32.to_longu f) as [n|] eqn:EQ; simpl in H2; inv H2. + exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. + apply Float32.to_longu_double in EQ. + eapply eval_longuoffloat; eauto. simpl. + change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. Qed. Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. -- cgit From 27d53418eff4e246a842a46b0883edda6860e3c2 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 13:07:02 +0200 Subject: cleaning Asmvliw semantics --- mppa_k1c/Asmblock.v | 5 ++- mppa_k1c/Asmblockdeps.v | 8 ++-- mppa_k1c/Asmvliw.v | 80 +++++++++++++++++++++++++++++--------- mppa_k1c/PostpassSchedulingproof.v | 22 +++-------- 4 files changed, 73 insertions(+), 42 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index b4cf57ae..f3f59f7d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1636,6 +1636,8 @@ Inductive final_state: state -> int -> Prop := Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). +(* Useless + Remark extcall_arguments_determ: forall rs m sg args1 args2, extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. @@ -1695,6 +1697,7 @@ Ltac Equalities := - (* final states *) inv H; inv H0. congruence. Qed. +*) Definition data_preg (r: preg) : bool := match r with @@ -1707,7 +1710,7 @@ Definition data_preg (r: preg) : bool := (** Determinacy of the [Asm] semantics. *) -(* TODO. +(* Useless. Remark extcall_arguments_determ: forall rs m sg args1 args2, diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index dd876485..6d98ab9b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -2158,15 +2158,13 @@ Proof. constructor; auto. Qed. -Lemma bblock_para_check_correct: - forall ge fn bb rs m rs' m' o, +Lemma bblock_para_check_correct ge fn bb rs m rs' m': Ge = Genv ge fn -> exec_bblock ge fn bb rs m = Next rs' m' -> bblock_para_check bb = true -> - parexec_bblock ge fn bb rs m o -> - o = Next rs' m'. + det_parexec ge fn bb rs m rs' m'. Proof. - intros. unfold bblock_para_check in H1. + intros H H0 H1 o H2. unfold bblock_para_check in H1. exploit forward_simu; eauto. eapply trans_state_match. intros (s2' & EXEC & MS). exploit forward_simu_par_alt. 2: apply (trans_state_match (State rs m)). all: eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index d553c612..1b3e0897 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -256,12 +256,14 @@ Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rsr rsw: regset) | Stuck => Stuck end. +(** 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. -Definition parexec_bblock (f: function) (b: bblock) (rs: regset) (m: mem) (o: outcome): Prop := - exists bdy1 bdy2, Permutation (bdy1++bdy2) (body b) /\ - o=match parexec_wio_bblock_aux f bdy1 (exit b) (Ptrofs.repr (size b)) rs rs m m with +(** 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 | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw | Stuck => Stuck end. @@ -276,14 +278,26 @@ Proof. destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. Qed. +(** deterministic parallel (out-of-order writes) execution of bundles *) +Definition det_parexec (f: function) (bundle: bblock) (rs: regset) (m: mem) rs' m': Prop := + forall o, parexec_bblock f bundle rs m o -> o = Next rs' m'. + + +Local Hint Resolve parexec_bblock_write_in_order. + +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'. +Proof. + unfold det_parexec; auto. +Qed. + Inductive step: state -> trace -> state -> Prop := | exec_step_internal: - forall b ofs f bi rs m rs' m', + forall b ofs f bundle rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> - parexec_wio_bblock f bi rs m = Next rs' m' -> - (forall o, parexec_bblock f bi rs m o -> o=(Next rs' m')) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + det_parexec f bundle rs m rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' bi, @@ -315,7 +329,29 @@ End RELSEM. Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). -Lemma semantics_determinate: forall p, determinate (semantics p). +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate p: determinate (semantics p). Proof. Ltac Equalities := match goal with @@ -323,14 +359,20 @@ Ltac Equalities := rewrite H1 in H2; inv H2; Equalities | _ => idtac end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. +Ltac Det_WIO X := + match goal with + | [ H: det_parexec _ _ _ _ _ _ _ |- _ ] => + exploit det_parexec_write_in_order; [ eapply H | idtac]; clear H; intro X + | _ => idtac + end. + intros; constructor; simpl. +- (* 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 H4. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. - rewrite H10 in H4. discriminate. - + unfold parexec_wio_bblock, parexec_wio_bblock_aux in H11. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. - rewrite H4 in H11. discriminate. + + unfold parexec_wio_bblock, parexec_wio_bblock_aux 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. + 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]. split. auto. intros. destruct B; auto. subst. auto. @@ -343,12 +385,12 @@ Ltac Equalities := eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. - (* initial states *) - inv H; inv H0. f_equal. congruence. + intros s1 s2 H H0; inv H; inv H0; f_equal; congruence. - (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + intros s r H; assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. + inv H. red; intros; red; intros. inv H; rewrite H0 in *; eelim NOTNULL; eauto. - (* final states *) - inv H; inv H0. congruence. + intros s r1 r2 H H0; inv H; inv H0. congruence. Qed. \ No newline at end of file diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 4e33fc90..4433bb1d 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -776,37 +776,26 @@ Proof. intros; eapply find_bblock_Some_in; eauto. Qed. -Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m' o: +Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m': exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> verify_par_bblock bundle = OK tt -> - parexec_bblock (globalenv (semantics tprog)) f bundle rs m o -> o = Next rs' m'. + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. Proof. intros. unfold verify_par_bblock in H0. destruct (Asmblockdeps.bblock_para_check _) eqn:BPC; try discriminate. clear H0. - simpl in H. simpl in H1. + simpl in H. eapply Asmblockdeps.bblock_para_check_correct; eauto. Qed. -Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m' o: +Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m': Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> - parexec_bblock (globalenv (semantics tprog)) f bundle rs m o -> o = Next rs' m'. + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. Proof. intros; eapply checked_bundles_are_parexec_equiv; eauto. eapply all_bundles_are_checked; eauto. Qed. -Lemma seqexec_parexec_wio b ofs f bundle rs rs' m m': - Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> - exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> - parexec_wio_bblock (globalenv (semantics tprog)) f bundle rs m = Next rs' m'. -Proof. - intros; erewrite <- seqexec_parexec_equiv; eauto. - eapply parexec_bblock_write_in_order. -Qed. - - Theorem transf_program_correct_Asmvliw: forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). Proof. @@ -814,7 +803,6 @@ Proof. - intros; subst; auto. - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. + eapply exec_step_internal; eauto. - eapply seqexec_parexec_wio; eauto. intros; eapply seqexec_parexec_equiv; eauto. + eapply exec_step_builtin; eauto. + eapply exec_step_external; eauto. -- cgit From 57abaaef9428e55830c9f82196c857daf04fb027 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 14:23:36 +0200 Subject: simpler parexec_wio_bblock_aux --- mppa_k1c/Asmblockdeps.v | 4 ++-- mppa_k1c/Asmvliw.v | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 6d98ab9b..b5b53fda 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1834,7 +1834,7 @@ Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Next rs' m' -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> exists s', macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' /\ match_states (State rs' m') s'. @@ -1946,7 +1946,7 @@ Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) (par_nextblock (Ptrofs.repr sz) rsw) mw = Stuck -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Stuck -> macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Proof. intros GENV MSR MSW H0. inv MSR; inv MSW. destruct ex as [ctl|]; try discriminate. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 1b3e0897..ac73853d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -251,7 +251,6 @@ Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rsr rsw: regset) match parexec_wio_body bdy rsr rsw mr mw with | Next rsw mw => let rsr := par_nextblock size_b rsr in - let rsw := par_nextblock size_b rsw in parexec_control f ext rsr rsw mw | Stuck => Stuck end. -- cgit From 7a8fabc6669ebc3fa953820e424a9ba712061ec7 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 14:47:22 +0200 Subject: minor simpl --- mppa_k1c/abstractbb/Parallelizability.v | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 065c0922..c2efd552 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -79,31 +79,37 @@ Proof. + intros H1; rewrite H1; simpl; auto. Qed. + +Lemma prun_iw_app p1: forall m1 old p2, + prun_iw (p1++p2) m1 old = + match prun_iw p1 m1 old with + | Some m2 => prun_iw p2 m2 old + | None => None + end. +Proof. + induction p1; simpl; try congruence. + intros; destruct (macro_prun _ _ _); simpl; auto. +Qed. + Lemma prun_iw_app_None p1: forall m1 old p2, prun_iw p1 m1 old = None -> prun_iw (p1++p2) m1 old = None. Proof. - induction p1; simpl; try congruence. - intros; destruct (macro_prun _ _ _); simpl; auto. + intros m1 old p2 H; rewrite prun_iw_app. rewrite H; auto. Qed. Lemma prun_iw_app_Some p1: forall m1 old m2 p2, prun_iw p1 m1 old = Some m2 -> prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. Proof. - induction p1; simpl; try congruence. - intros; destruct (macro_prun _ _ _); simpl; auto. - congruence. + intros m1 old m2 p2 H; rewrite prun_iw_app. rewrite H; auto. Qed. - End PARALLEL. End ParallelSemantics. - - Fixpoint notIn {A} (x: A) (l:list A): Prop := match l with | nil => True -- cgit From 31d1adf2a19515b97c32cb5f1a68b5befc276ce5 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 16:49:55 +0200 Subject: petite factorisation de preuve --- mppa_k1c/Asmblockdeps.v | 128 ++++++++++++++++++++++-------------------------- 1 file changed, 59 insertions(+), 69 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b5b53fda..a98ab53a 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1631,16 +1631,16 @@ Arguments ppos: simpl never. Variable Ge: genv. -Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' mw' i: +Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_arith_instr ge i rsr rsw = rsw' -> mw = mw' -> + parexec_arith_instr ge i rsr rsw = rsw' -> exists sw', macro_prun Ge (trans_arith i) sw sr sr = Some sw' - /\ match_states (State rsw' mw') sw'. + /\ match_states (State rsw' mw) sw'. Proof. - intros GENV MSR MSW PARARITH MWEQ. subst. inv MSR. inv MSW. + intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. unfold parexec_arith_instr. destruct i. (* Ploadsymbol *) - destruct i. eexists; split; [| split]. @@ -1716,63 +1716,73 @@ Proof. destruct (ireg_eq g rd); subst; Simpl. Qed. -Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi rsw' mw': +Theorem forward_simu_par_wio_basic_gen 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 -> - parexec_basic_instr ge bi rsr rsw mr mw = Next rsw' mw' -> - exists sw', - macro_prun Ge (trans_basic bi) sw sr sr = Some sw' - /\ match_states (State rsw' mw') sw'. + match_outcome (parexec_basic_instr ge bi rsr rsw mr mw) (macro_prun Ge (trans_basic bi) sw sr sr). Proof. - intros GENV MSR MSW H. - destruct bi. + intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). + destruct bi; simpl. (* Arith *) - - simpl in H. inversion H. subst rsw' mw'. simpl macro_prun. eapply trans_arith_par_correct; eauto. + - exploit trans_arith_par_correct. 5: eauto. all: eauto. (* Load *) - - simpl in H. destruct i. - unfold parexec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H. inv MSR; inv MSW; - eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; pose (H0 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| - Simpl| - intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); [ - subst; Simpl| - Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. + - destruct i; unfold parexec_load; simpl; unfold exec_load_deps. + erewrite GENV, H, H0. + destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto. + destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto. + eexists; intuition eauto; Simpl. + destruct r; Simpl; + destruct (ireg_eq g rd); [ + subst; Simpl| + Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]. (* Store *) - - simpl in H. destruct i. - unfold parexec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate. - destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate. inv H; inv MSR; inv MSW. - eexists; split; try split. - * simpl. rewrite EVALOFF. rewrite H. rewrite (H0 ra). rewrite (H0 rs). rewrite MEML. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. + - destruct i; unfold parexec_store; simpl; unfold exec_store_deps. + erewrite GENV, H, ! H0. + destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto. + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto. + eexists; intuition eauto; Simpl. (* Allocframe *) - - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. - inv H. inv MSR. inv MSW. eexists. split; try split. - * simpl. Simpl. rewrite (H0 GPR12). rewrite H. rewrite MEMAL. rewrite MEMS. Simpl. - rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. -(* Freeframe *) - - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rsr GPR12) eqn:SPeq; try discriminate. - destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv MSR. inv MSW. - eexists. split; try split. - * simpl. rewrite (H0 GPR12). rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. - Simpl. rewrite (H0 GPR12). rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. + - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. + * eexists; repeat split. + { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. + rewrite H, MEMAL. rewrite MEMS. reflexivity. } + { Simpl. } + { intros rr; destruct rr; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. } + * simpl; Simpl; erewrite !H0, H, MEMAL, MEMS; auto. + (* Freeframe *) + - erewrite !H0, H. + destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto. + destruct (rsr GPR12) eqn:SPeq; simpl; auto. + destruct (Mem.free _ _ _ _) eqn:MFREE; simpl; auto. + eexists; repeat split. + * simpl. Simpl. erewrite H0, SPeq, MLOAD, MFREE. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. (* Pget *) - - simpl in H. destruct rs eqn:rseq; try discriminate. inv H. inv MSR. inv MSW. - eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. + - destruct rs eqn:rseq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* Pset *) - - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv MSR; inv MSW. - eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. + - destruct rd eqn:rdeq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. (* Pnop *) - - simpl in H. inv H. inv MSR. inv MSW. eexists. split; try split. assumption. assumption. + - eexists. repeat split; assumption. +Qed. + + +Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi rsw' mw': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_basic_instr ge bi rsr rsw mr mw = Next rsw' mw' -> + exists sw', + macro_prun Ge (trans_basic bi) sw sr sr = Some sw' + /\ match_states (State rsw' mw') sw'. +Proof. + intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. + simpl; auto. Qed. Theorem forward_simu_par_wio_basic_Stuck ge fn rsr rsw mr mw sr sw bi: @@ -1782,28 +1792,8 @@ Theorem forward_simu_par_wio_basic_Stuck ge fn rsr rsw mr mw sr sw bi: parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> macro_prun Ge (trans_basic bi) sw sr sr = None. Proof. - intros GENV MSR MSW H0. inv MSR; inv MSW. - unfold parexec_basic_instr in H0. destruct bi; try discriminate. -(* PLoad *) - - destruct i; destruct i. - all: simpl; rewrite H; rewrite (H1 ra); unfold parexec_load in H0; - destruct (eval_offset _ _); auto; destruct (Mem.loadv _ _ _); auto; discriminate. -(* PStore *) - - destruct i; destruct i; - simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); - unfold parexec_store in H0; destruct (eval_offset _ _); auto; destruct (Mem.storev _ _ _); auto; discriminate. -(* Pallocframe *) - - simpl. Simpl. rewrite (H1 SP). rewrite H. destruct (Mem.alloc _ _ _). simpl in H0. - destruct (Mem.store _ _ _ _); try discriminate. reflexivity. -(* Pfreeframe *) - - simpl. Simpl. rewrite (H1 SP). rewrite H. - destruct (Mem.loadv _ _ _); auto. destruct (rsr GPR12); auto. destruct (Mem.free _ _ _ _); auto. - discriminate. -(* Pget *) - - simpl. destruct rs; subst; try discriminate. - all: simpl; auto. - - simpl. destruct rd; subst; try discriminate. - all: simpl; auto. + intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. + simpl; auto. Qed. Theorem forward_simu_par_body: -- cgit From 714a1fb988da03066629970325089e16dd146432 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 17:55:08 +0200 Subject: renommages abstract_bb Resource -> PseudoReg macro -> inst --- mppa_k1c/Asmblockdeps.v | 48 ++++----- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 24 ++--- mppa_k1c/abstractbb/DepTreeTheory.v | 58 +++++----- mppa_k1c/abstractbb/ImpDep.v | 28 ++--- mppa_k1c/abstractbb/Parallelizability.v | 154 +++++++++++++-------------- 5 files changed, 156 insertions(+), 156 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a98ab53a..7043bd32 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -542,7 +542,7 @@ Definition inv_ppos (p: R.t) : option preg := Notation "a @ b" := (Econs a b) (at level 102, right associativity). -Definition trans_control (ctl: control) : macro := +Definition trans_control (ctl: control) : inst := match ctl with | Pret => [(#PC, Name (#RA))] | Pcall s => [(#RA, Name (#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] @@ -558,14 +558,14 @@ Definition trans_control (ctl: control) : macro := | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] end. -Definition trans_exit (ex: option control) : L.macro := +Definition trans_exit (ex: option control) : L.inst := match ex with | None => [] | Some ctl => trans_control ctl end . -Definition trans_arith (ai: ar_instruction) : macro := +Definition trans_arith (ai: ar_instruction) : inst := match ai with | PArithR n d => [(#d, Op (Arith (OArithR n)) Enil)] | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (Name (#s) @ Enil))] @@ -582,7 +582,7 @@ Definition trans_arith (ai: ar_instruction) : macro := end. -Definition trans_basic (b: basic) : macro := +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)) (Name (#a) @ Name pmem @ Enil))] @@ -603,13 +603,13 @@ Definition trans_basic (b: basic) : macro := | Pnop => [] end. -Fixpoint trans_body (b: list basic) : list L.macro := +Fixpoint trans_body (b: list basic) : list L.inst := match b with | nil => nil | b :: lb => (trans_basic b) :: (trans_body lb) end. -Definition trans_pcincr (sz: Z) (k: L.macro) := (#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k. +Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k. Definition trans_block (b: Asmblock.bblock) : L.bblock := trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). @@ -686,7 +686,7 @@ Lemma exec_app_some: Proof. induction c. - simpl. intros. congruence. - - intros. simpl in *. destruct (macro_run _ _ _ _); auto. eapply IHc; eauto. discriminate. + - intros. simpl in *. destruct (inst_run _ _ _ _); auto. eapply IHc; eauto. discriminate. Qed. Lemma exec_app_none: @@ -696,7 +696,7 @@ Lemma exec_app_none: Proof. induction c. - simpl. discriminate. - - intros. simpl. simpl in H. destruct (macro_run _ _ _ _); auto. + - intros. simpl. simpl in H. destruct (inst_run _ _ _ _); auto. Qed. Lemma trans_arith_correct: @@ -704,7 +704,7 @@ Lemma trans_arith_correct: exec_arith_instr ge i rs = rs' -> match_states (State rs m) s -> exists s', - macro_run (Genv ge fn) (trans_arith i) s s = Some s' + inst_run (Genv ge fn) (trans_arith i) s s = Some s' /\ match_states (State rs' m) s'. Proof. intros. unfold exec_arith_instr in H. destruct i. @@ -793,12 +793,12 @@ Lemma forward_simu_basic: exec_basic_instr ge b rs m = Next rs' m' -> match_states (State rs m) s -> exists s', - macro_run (Genv ge fn) (trans_basic b) s s = Some s' + inst_run (Genv ge fn) (trans_basic b) s s = Some s' /\ match_states (State rs' m') s'. Proof. intros. destruct b. (* Arith *) - - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. + - simpl in H. inv H. simpl inst_run. eapply trans_arith_correct; eauto. (* Load *) - simpl in H. destruct i. unfold exec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; @@ -1040,11 +1040,11 @@ Proof. eapply IHc; eauto. Qed. -Lemma exec_trans_pcincr_exec_macrorun: +Lemma exec_trans_pcincr_exec_instrun: forall rs m s b k, match_states (State rs m) s -> exists s', - macro_run Ge ((# PC, Op (OIncremPC (size b)) (Name (# PC) @ Enil)) :: k) s s = macro_run Ge k s' s + inst_run Ge ((# PC, Op (OIncremPC (size b)) (Name (# PC) @ Enil)) :: k) s s = inst_run Ge k s' s /\ match_states (State (nextblock b rs) m) s'. Proof. intros. inv H. eexists. split. simpl. pose (H1 PC); simpl in e; rewrite e. destruct Ge. simpl. eapply eq_refl. @@ -1053,9 +1053,9 @@ Proof. - intros rr; destruct rr; Simpl. Qed. -Lemma macro_run_trans_exit_noold: +Lemma inst_run_trans_exit_noold: forall ex s s' s'', - macro_run Ge (trans_exit ex) s s' = macro_run Ge (trans_exit ex) s s''. + inst_run Ge (trans_exit ex) s s' = inst_run Ge (trans_exit ex) s s''. Proof. intros. destruct ex. - destruct c; destruct i; reflexivity. @@ -1070,10 +1070,10 @@ Lemma exec_trans_pcincr_exec: /\ match_states (State (nextblock b rs) m) s'. Proof. intros. - exploit exec_trans_pcincr_exec_macrorun; eauto. + exploit exec_trans_pcincr_exec_instrun; eauto. intros (s' & MRUN & MS). eexists. split. unfold exec. unfold trans_pcincr. unfold run. rewrite MRUN. - erewrite macro_run_trans_exit_noold; eauto. + erewrite inst_run_trans_exit_noold; eauto. assumption. Qed. @@ -1603,7 +1603,7 @@ End SECT. (** Parallelizability of a bblock *) -Module PChk := ParallelChecks L PosResourceSet. +Module PChk := ParallelChecks L PosPseudoRegSet. Definition bblock_para_check (p: Asmblock.bblock) : bool := PChk.is_parallelizable (trans_block p). @@ -1637,7 +1637,7 @@ Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: match_states (State rsw mw) sw -> parexec_arith_instr ge i rsr rsw = rsw' -> exists sw', - macro_prun Ge (trans_arith i) sw sr sr = Some sw' + inst_prun Ge (trans_arith i) sw sr sr = Some sw' /\ match_states (State rsw' mw) sw'. Proof. intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. @@ -1720,7 +1720,7 @@ Theorem forward_simu_par_wio_basic_gen 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) (macro_prun Ge (trans_basic bi) sw sr sr). + match_outcome (parexec_basic_instr ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). Proof. intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). destruct bi; simpl. @@ -1778,7 +1778,7 @@ Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi rsw' mw': match_states (State rsw mw) sw -> parexec_basic_instr ge bi rsr rsw mr mw = Next rsw' mw' -> exists sw', - macro_prun Ge (trans_basic bi) sw sr sr = Some sw' + inst_prun Ge (trans_basic bi) sw sr sr = Some sw' /\ match_states (State rsw' mw') sw'. Proof. intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. @@ -1790,7 +1790,7 @@ Theorem forward_simu_par_wio_basic_Stuck ge fn rsr rsw mr mw sr sw bi: match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> - macro_prun Ge (trans_basic bi) sw sr sr = None. + inst_prun Ge (trans_basic bi) sw sr sr = None. Proof. intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. simpl; auto. @@ -1826,7 +1826,7 @@ Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': match_states (State rsw mw) sw -> parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> exists s', - macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' + inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' /\ match_states (State rs' m') s'. Proof. intros GENV MSR MSW H0. @@ -1937,7 +1937,7 @@ Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Stuck -> - macro_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. + inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Proof. intros GENV MSR MSW H0. inv MSR; inv MSW. destruct ex as [ctl|]; try discriminate. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 904fb72c..0bab9426 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -2,19 +2,19 @@ *) -Module Type ResourceNames. +Module Type PseudoRegisters. Parameter t: Type. Parameter eq_dec: forall (x y: t), { x = y } + { x<>y }. -End ResourceNames. +End PseudoRegisters. (** * Parameters of the language of Basic Blocks *) Module Type LangParam. -Declare Module R: ResourceNames. +Declare Module R: PseudoRegisters. Parameter value: Type. @@ -85,25 +85,25 @@ with list_exp_eval (le: list_exp) (m old: mem): option (list value) := | LOld le => list_exp_eval le old old end. -Definition macro := list (R.t * exp). (* = a sequence of assignments *) +Definition inst := list (R.t * exp). (* = a sequence of assignments *) -Fixpoint macro_run (i: macro) (m old: mem): option mem := +Fixpoint inst_run (i: inst) (m old: mem): option mem := match i with | nil => Some m | (x, e)::i' => match exp_eval e m old with - | Some v' => macro_run i' (assign m x v') old + | Some v' => inst_run i' (assign m x v') old | None => None end end. -Definition bblock := list macro. +Definition bblock := list inst. Fixpoint run (p: bblock) (m: mem): option mem := match p with | nil => Some m | i::p' => - match macro_run i m m with + match inst_run i m m with | Some m' => run p' m' | None => None end @@ -166,10 +166,10 @@ Qed. Definition bblock_equiv (p1 p2: bblock): Prop := forall m, res_eq (run p1 m) (run p2 m). -Lemma alt_macro_equiv_refl i old1 old2: +Lemma alt_inst_equiv_refl i old1 old2: (forall x, old1 x = old2 x) -> forall m1 m2, (forall x, m1 x = m2 x) -> - res_eq (macro_run i m1 old1) (macro_run i m2 old2). + res_eq (inst_run i m1 old1) (inst_run i m2 old2). Proof. intro H; induction i as [ | [x e]]; simpl; eauto. intros m1 m2 H1. erewrite exp_equiv; eauto. @@ -181,9 +181,9 @@ Qed. Lemma alt_bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). Proof. induction p as [ | i p']; simpl; eauto. - intros m1 m2 H; lapply (alt_macro_equiv_refl i m1 m2); auto. + intros m1 m2 H; lapply (alt_inst_equiv_refl i m1 m2); auto. intros X; lapply (X m1 m2); auto; clear X. - destruct (macro_run i m1 m1); simpl. + destruct (inst_run i m1 m1); simpl. - intros [m3 [H1 H2]]; rewrite H1; simpl; auto. - intros H1; rewrite H1; simpl; auto. Qed. diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index 353e9160..4d5c71b3 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -9,9 +9,9 @@ Require Setoid. (* in order to rewrite <-> *) Require Export AbstractBasicBlocksDef. -Module Type ResourceDictionary. +Module Type PseudoRegDictionary. -Declare Module R: ResourceNames. +Declare Module R: PseudoRegisters. Parameter t: Type -> Type. @@ -30,12 +30,12 @@ Parameter empty: forall {A}, t A. Parameter empty_spec: forall A x, get (empty (A:=A)) x = None. -End ResourceDictionary. +End PseudoRegDictionary. (** * Computations of "bblock" Dependencies and application to the equality test *) -Module DepTree (L: SeqLanguage) (Dict: ResourceDictionary with Module R:=L.LP.R). +Module DepTree (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). Export L. Export LP. @@ -142,21 +142,21 @@ Proof. eauto. Qed. -Fixpoint macro_deps (i: macro) (d old: deps): deps := +Fixpoint inst_deps (i: inst) (d old: deps): deps := match i with | nil => d | (x, e)::i' => let t0:=deps_get d x in let t1:=exp_tree e d old in let v':=if failsafe t0 then t1 else (Terase t1 t0) in - macro_deps i' (Dict.set d x v') old + inst_deps i' (Dict.set d x v') old end. Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps := match p with | nil => d | i::p' => - let d':=macro_deps i d d in + let d':=inst_deps i d d in bblock_deps_rec p' d' end. @@ -177,9 +177,9 @@ Proof. - intros; erewrite IHe, IHe0; eauto. Qed. -Lemma tree_eval_macro_abort i m0 x old: forall d, +Lemma tree_eval_inst_abort i m0 x old: forall d, tree_eval (deps_get d x) m0 = None -> - tree_eval (deps_get (macro_deps i d old) x) m0 = None. + tree_eval (deps_get (inst_deps i d old) x) m0 = None. Proof. induction i as [|[y e] i IHi]; simpl; auto. intros d H; erewrite IHi; eauto. clear IHi. @@ -197,15 +197,15 @@ Lemma tree_eval_abort p m0 x: forall d, Proof. induction p; simpl; auto. intros d H; erewrite IHp; eauto. clear IHp. - eapply tree_eval_macro_abort; eauto. + eapply tree_eval_inst_abort; eauto. Qed. -Lemma tree_eval_macro_Some_correct1 i m0 old od: +Lemma tree_eval_inst_Some_correct1 i m0 old od: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall (m1 m2: mem) d, - macro_run ge i m1 old = Some m2 -> + inst_run ge i m1 old = Some m2 -> (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (macro_deps i d od) x) m0 = Some (m2 x)). + (forall x, tree_eval (deps_get (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. @@ -222,7 +222,7 @@ Proof. + inversion H. Qed. -Local Hint Resolve tree_eval_macro_Some_correct1 tree_eval_abort. +Local Hint Resolve tree_eval_inst_Some_correct1 tree_eval_abort. Lemma tree_eval_Some_correct1 p m0: forall (m1 m2: mem) d, run ge p m1 = Some m2 -> @@ -232,7 +232,7 @@ Proof. induction p as [ | i p]; simpl; intros m1 m2 d H. - inversion_clear H; eauto. - intros H0 x0. - remember (macro_run ge i m1 m1) as om. + remember (inst_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _ _ _ _); eauto. + inversion H. @@ -246,10 +246,10 @@ Proof. intros; autorewrite with dict_rw; simpl; eauto. Qed. -Lemma tree_eval_macro_None_correct i m0 old od: +Lemma tree_eval_inst_None_correct i m0 old od: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall m1 d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - macro_run ge i m1 old = None <-> exists x, tree_eval (deps_get (macro_deps i d od) x) m0 = None. + inst_run ge i m1 old = None <-> exists x, tree_eval (deps_get (inst_deps i d od) x) m0 = None. Proof. intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. @@ -264,7 +264,7 @@ Proof. * rewrite set_spec_diff; auto. + intuition. constructor 1 with (x:=x); simpl. - apply tree_eval_macro_abort. + apply tree_eval_inst_abort. autorewrite with dict_rw. destruct (failsafe (deps_get d x)); simpl; try rewrite H0; erewrite tree_eval_exp; eauto. @@ -278,12 +278,12 @@ Proof. induction p as [|i p IHp]; simpl; intros m1 d. - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. - intros H0. - remember (macro_run ge i m1 m1) as om. + remember (inst_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _); eauto. + intuition. - assert (X: macro_run ge i m1 m1 = None); auto. - rewrite tree_eval_macro_None_correct in X; auto. + assert (X: inst_run ge i m1 m1 = None); auto. + rewrite tree_eval_inst_None_correct in X; auto. destruct X as [x H1]. constructor 1 with (x:=x); simpl; auto. Qed. @@ -295,12 +295,12 @@ Proof. intros; autorewrite with dict_rw; simpl; eauto. Qed. -Lemma tree_eval_macro_Some_correct2 i m0 old od: +Lemma tree_eval_inst_Some_correct2 i m0 old od: (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> forall (m1 m2: mem) d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (macro_deps i d od) x) m0 = Some (m2 x)) -> - res_eq (Some m2) (macro_run ge i m1 old). + (forall x, tree_eval (deps_get (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 H0. @@ -317,7 +317,7 @@ Proof. erewrite tree_eval_exp; eauto. * rewrite set_spec_diff; auto. + generalize (H x). - rewrite tree_eval_macro_abort; try discriminate. + rewrite tree_eval_inst_abort; try discriminate. autorewrite with dict_rw. destruct (failsafe (deps_get d x)); simpl; try rewrite H0; erewrite tree_eval_exp; eauto. @@ -333,11 +333,11 @@ Proof. generalize (H0 x); rewrite H. congruence. - intros H. - remember (macro_run ge i m1 m1) as om. + remember (inst_run ge i m1 m1) as om. destruct om. + refine (IHp _ _ _ _ _); eauto. - + assert (X: macro_run ge i m1 m1 = None); auto. - rewrite tree_eval_macro_None_correct in X; auto. + + assert (X: inst_run ge i m1 m1 = None); auto. + rewrite tree_eval_inst_None_correct in X; auto. destruct X as [x H1]. generalize (H x). rewrite tree_eval_abort; congruence. @@ -377,7 +377,7 @@ End DepTree. Require Import PArith. Require Import FMapPositive. -Module PosDict <: ResourceDictionary with Module R:=Pos. +Module PosDict <: PseudoRegDictionary with Module R:=Pos. Module R:=Pos. diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 9051f6ad..3cc85fd5 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -42,7 +42,7 @@ End ISeqLanguage. Module Type ImpDict. -Include ResourceDictionary. +Include PseudoRegDictionary. Parameter eq_test: forall {A}, t A -> t A -> ?? bool. @@ -209,7 +209,7 @@ Hint Resolve hexp_tree_correct: wlp. Variable debug_assign: R.t -> ?? option pstring. -Fixpoint hmacro_deps (i: macro) (d od: hdeps): ?? hdeps := +Fixpoint hinst_deps (i: inst) (d od: hdeps): ?? hdeps := match i with | nil => RET d | (x, e)::i' => @@ -221,7 +221,7 @@ Fixpoint hmacro_deps (i: macro) (d od: hdeps): ?? hdeps := else DO t1 <~ hexp_tree e d od None;; hTerase t1 t0 dbg);; - hmacro_deps i' (Dict.set d x v') od + hinst_deps i' (Dict.set d x v') od end. Lemma pset_spec_eq d x t: @@ -244,11 +244,11 @@ Qed. Hint Rewrite pset_spec_eq pempty_spec: dict_rw. -Lemma hmacro_deps_correct i: forall d1 od1, - WHEN hmacro_deps i d1 od1 ~> d1' THEN +Lemma hinst_deps_correct i: forall d1 od1, + WHEN hinst_deps i d1 od1 ~> d1' THEN forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> (forall x, pdeps_get d1 x = deps_get d2 x) -> - forall x, pdeps_get d1' x = deps_get (macro_deps i d2 od2) x. + forall x, pdeps_get d1' x = deps_get (inst_deps i d2 od2) x. Proof. induction i; simpl; wlp_simplify. + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). @@ -265,10 +265,10 @@ Proof. * rewrite set_spec_diff, pset_spec_diff; auto. - rewrite H, H5; auto. Qed. -Global Opaque hmacro_deps. -Hint Resolve hmacro_deps_correct: wlp. +Global Opaque hinst_deps. +Hint Resolve hinst_deps_correct: wlp. -(* logging info: we log the number of macro-instructions passed ! *) +(* logging info: we log the number of inst-instructions passed ! *) Variable log: unit -> ?? unit. Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := @@ -276,7 +276,7 @@ Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := | nil => RET d | i::p' => log tt;; - DO d' <~ hmacro_deps i d d;; + DO d' <~ hinst_deps i d d;; hbblock_deps_rec p' d' end. @@ -371,10 +371,10 @@ Local Hint Resolve hbblock_deps_correct Dict.eq_test_correct: wlp. Section Prog_Eq_Gen. -Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 macros *) -Variable dbg2: R.t -> ?? option pstring. (* log of p2 macros *) -Variable log1: unit -> ?? unit. (* log of p1 macros *) -Variable log2: unit -> ?? unit. (* log of p2 macros *) +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. diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index c2efd552..519e7e54 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -21,20 +21,20 @@ Local Open Scope list. Section PARALLEL. Variable ge: genv. -(* parallel run of a macro *) -Fixpoint macro_prun (i: macro) (m tmp old: mem): option mem := +(* parallel run of a inst *) +Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem := match i with | nil => Some m | (x, e)::i' => match exp_eval ge e tmp old with - | Some v' => macro_prun i' (assign m x v') (assign tmp x v') old + | Some v' => inst_prun i' (assign m x v') (assign tmp x v') old | None => None end end. -(* [macro_prun] is generalization of [macro_run] *) -Lemma macro_run_prun i: forall m old, - macro_run ge i m old = macro_prun i m m old. +(* [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. induction i as [|[y e] i']; simpl; auto. intros m old; destruct (exp_eval ge e m old); simpl; auto. @@ -46,7 +46,7 @@ Fixpoint prun_iw (p: bblock) m old: option mem := match p with | nil => Some m | i::p' => - match macro_prun i m old old with + match inst_prun i m old old with | Some m1 => prun_iw p' m1 old | None => None end @@ -58,9 +58,9 @@ Definition prun (p: bblock) m (om: option mem) := exists p', res_eq om (prun_iw (* a few lemma on equality *) -Lemma macro_prun_equiv i old: forall m1 m2 tmp, +Lemma inst_prun_equiv i old: forall m1 m2 tmp, (forall x, m1 x = m2 x) -> - res_eq (macro_prun i m1 tmp old) (macro_prun i m2 tmp old). + res_eq (inst_prun i m1 tmp old) (inst_prun i m2 tmp old). Proof. induction i as [|[x e] i']; simpl; eauto. intros m1 m2 tmp H; destruct (exp_eval ge e tmp old); simpl; auto. @@ -73,8 +73,8 @@ Lemma prun_iw_equiv p: forall m1 m2 old, Proof. induction p as [|i p']; simpl; eauto. - intros m1 m2 old H. - generalize (macro_prun_equiv i old m1 m2 old H); - destruct (macro_prun i m1 old old); simpl. + generalize (inst_prun_equiv i old m1 m2 old H); + destruct (inst_prun i m1 old old); simpl. + intros (m3 & H3 & H4); rewrite H3; simpl; eauto. + intros H1; rewrite H1; simpl; auto. Qed. @@ -88,7 +88,7 @@ Lemma prun_iw_app p1: forall m1 old p2, end. Proof. induction p1; simpl; try congruence. - intros; destruct (macro_prun _ _ _); simpl; auto. + intros; destruct (inst_prun _ _ _); simpl; auto. Qed. Lemma prun_iw_app_None p1: forall m1 old p2, @@ -272,15 +272,15 @@ Qed. (** * Writing frames *) -Fixpoint macro_wframe(i:macro): list R.t := +Fixpoint inst_wframe(i:inst): list R.t := match i with | nil => nil - | a::i' => (fst a)::(macro_wframe i') + | a::i' => (fst a)::(inst_wframe i') end. -Lemma macro_wframe_correct i m' old: forall m tmp, - macro_prun ge i m tmp old = Some m' -> - forall x, notIn x (macro_wframe i) -> m' x = m x. +Lemma inst_wframe_correct i m' old: forall m tmp, + inst_prun ge i m tmp old = Some m' -> + forall x, notIn x (inst_wframe i) -> m' x = m x. Proof. induction i as [|[y e] i']; simpl. - intros m tmp H x H0; inversion_clear H; auto. @@ -289,47 +289,47 @@ Proof. rewrite assign_diff; auto. Qed. -Lemma macro_prun_fequiv i old: forall m1 m2 tmp, - frame_eq (fun x => In x (macro_wframe i)) (macro_prun ge i m1 tmp old) (macro_prun ge i m2 tmp old). +Lemma inst_prun_fequiv i old: forall m1 m2 tmp, + frame_eq (fun x => In x (inst_wframe i)) (inst_prun ge i m1 tmp old) (inst_prun ge i m2 tmp old). Proof. induction i as [|[y e] i']; simpl. - intros m1 m2 tmp; eexists; intuition eauto. - intros m1 m2 tmp. destruct (exp_eval ge e tmp old); simpl; auto. eapply frame_eq_list_split; eauto. clear IHi'. intros m1' m2' x H1 H2. - lapply (macro_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. - lapply (macro_wframe_correct i' m2' old (assign m2 y v) (assign tmp y v)); eauto. + lapply (inst_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. + lapply (inst_wframe_correct i' m2' old (assign m2 y v) (assign tmp y v)); eauto. intros Xm2 Xm1 H H0. destruct H. + subst. rewrite Xm1, Xm2; auto. rewrite !assign_eq. auto. + rewrite <- notIn_iff in H0; tauto. Qed. -Lemma macro_prun_None i m1 m2 tmp old: - macro_prun ge i m1 tmp old = None -> - macro_prun ge i m2 tmp old = None. +Lemma inst_prun_None i m1 m2 tmp old: + inst_prun ge i m1 tmp old = None -> + inst_prun ge i m2 tmp old = None. Proof. - intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). + intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). rewrite H; simpl; auto. Qed. -Lemma macro_prun_Some i m1 m2 tmp old m1': - macro_prun ge i m1 tmp old = Some m1' -> - res_eq (Some (frame_assign m2 (macro_wframe i) m1')) (macro_prun ge i m2 tmp old). +Lemma inst_prun_Some i m1 m2 tmp old m1': + inst_prun ge i m1 tmp old = Some m1' -> + res_eq (Some (frame_assign m2 (inst_wframe i) m1')) (inst_prun ge i m2 tmp old). Proof. - intros H; generalize (macro_prun_fequiv i old m1 m2 tmp). + intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). rewrite H; simpl. intros (m2' & H1 & H2). eexists; intuition eauto. rewrite frame_assign_def. - lapply (macro_wframe_correct i m2' old m2 tmp); eauto. - destruct (notIn_dec x (macro_wframe i)); auto. + lapply (inst_wframe_correct i m2' old m2 tmp); eauto. + destruct (notIn_dec x (inst_wframe i)); auto. intros X; rewrite X; auto. Qed. Fixpoint bblock_wframe(p:bblock): list R.t := match p with | nil => nil - | i::p' => (macro_wframe i)++(bblock_wframe p') + | i::p' => (inst_wframe i)++(bblock_wframe p') end. Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm. @@ -350,11 +350,11 @@ Proof. induction p as [|i p']; simpl. - intros m H; inversion_clear H; auto. - intros m H x; rewrite notIn_app; intros (H1 & H2). - remember (macro_prun i m old old) as om. + remember (inst_prun i m old old) as om. destruct om as [m1|]; simpl. + eapply eq_trans. eapply IHp'; eauto. - eapply macro_wframe_correct; eauto. + eapply inst_wframe_correct; eauto. + inversion H. Qed. @@ -363,13 +363,13 @@ Lemma prun_iw_fequiv p old: forall m1 m2, Proof. induction p as [|i p']; simpl. - intros m1 m2; eexists; intuition eauto. - - intros m1 m2; generalize (macro_prun_fequiv i old m1 m2 old). - remember (macro_prun i m1 old old) as om. + - intros m1 m2; generalize (inst_prun_fequiv i old m1 m2 old). + remember (inst_prun i m1 old old) as om. destruct om as [m1'|]; simpl. + intros (m2' & H1 & H2). rewrite H1; simpl. eapply frame_eq_list_split; eauto. clear IHp'. intros m1'' m2'' x H3 H4. rewrite in_app_iff. - intros X X2. assert (X1: In x (macro_wframe i)). { destruct X; auto. rewrite <- notIn_iff in X2; tauto. } + intros X X2. assert (X1: In x (inst_wframe i)). { destruct X; auto. rewrite <- notIn_iff in X2; tauto. } clear X. lapply (bblock_wframe_correct p' m1'' old m1'); eauto. lapply (bblock_wframe_correct p' m2'' old m2'); eauto. @@ -397,7 +397,7 @@ Fixpoint is_det (p: bblock): Prop := match p with | nil => True | i::p' => - disjoint (macro_wframe i) (bblock_wframe p') (* no WRITE-AFTER-WRITE *) + disjoint (inst_wframe i) (bblock_wframe p') (* no WRITE-AFTER-WRITE *) /\ is_det p' end. @@ -419,32 +419,32 @@ Theorem is_det_correct p p': Proof. induction 1 as [ | i p p' | i1 i2 p | p1 p2 p3 ]; simpl; eauto. - intros [H0 H1] m old. - remember (macro_prun ge i m old old) as om0. + remember (inst_prun ge i m old old) as om0. destruct om0 as [ m0 | ]; simpl; auto. - rewrite disjoint_app_r. intros ([Z1 Z2] & Z3 & Z4) m old. - remember (macro_prun ge i2 m old old) as om2. + remember (inst_prun ge i2 m old old) as om2. destruct om2 as [ m2 | ]; simpl; auto. - + remember (macro_prun ge i1 m old old) as om1. + + remember (inst_prun ge i1 m old old) as om1. destruct om1 as [ m1 | ]; simpl; auto. - * lapply (macro_prun_Some i2 m m1 old old m2); simpl; auto. - lapply (macro_prun_Some i1 m m2 old old m1); simpl; auto. + * lapply (inst_prun_Some i2 m m1 old old m2); simpl; auto. + lapply (inst_prun_Some i1 m m2 old old m1); simpl; auto. intros (m1' & Hm1' & Xm1') (m2' & Hm2' & Xm2'). rewrite Hm1', Hm2'; simpl. eapply prun_iw_equiv. intros x; rewrite <- Xm1', <- Xm2'. clear Xm2' Xm1' Hm1' Hm2' m1' m2'. rewrite frame_assign_def. rewrite disjoint_sym in Z1; unfold disjoint in Z1. - destruct (notIn_dec x (macro_wframe i1)) as [ X1 | X1 ]. - { rewrite frame_assign_def; destruct (notIn_dec x (macro_wframe i2)) as [ X2 | X2 ]; auto. - erewrite (macro_wframe_correct i2 m2 old m old); eauto. - erewrite (macro_wframe_correct i1 m1 old m old); eauto. + destruct (notIn_dec x (inst_wframe i1)) as [ X1 | X1 ]. + { rewrite frame_assign_def; destruct (notIn_dec x (inst_wframe i2)) as [ X2 | X2 ]; auto. + erewrite (inst_wframe_correct i2 m2 old m old); eauto. + erewrite (inst_wframe_correct i1 m1 old m old); eauto. } rewrite frame_assign_notIn; auto. - * erewrite macro_prun_None; eauto. simpl; auto. - + remember (macro_prun ge i1 m old old) as om1. + * erewrite inst_prun_None; eauto. simpl; auto. + + remember (inst_prun ge i1 m old old) as om1. destruct om1 as [ m1 | ]; simpl; auto. - erewrite macro_prun_None; eauto. + erewrite inst_prun_None; eauto. - intros; eapply res_eq_trans. eapply IHPermutation1; eauto. eapply IHPermutation2; eauto. @@ -479,23 +479,23 @@ Proof. intros; (eapply H1 || eapply H2); rewrite in_app_iff; auto. Qed. -Fixpoint macro_frame (i: macro): list R.t := +Fixpoint inst_frame (i: inst): list R.t := match i with | nil => nil - | a::i' => (fst a)::(exp_frame (snd a) ++ macro_frame i') + | a::i' => (fst a)::(exp_frame (snd a) ++ inst_frame i') end. -Lemma macro_wframe_frame i x: In x (macro_wframe i) -> In x (macro_frame i). +Lemma inst_wframe_frame i x: In x (inst_wframe i) -> In x (inst_frame i). Proof. induction i as [ | [y e] i']; simpl; intuition. Qed. -Lemma macro_frame_correct i wframe old1 old2: forall m tmp1 tmp2, - (disjoint (macro_frame i) wframe) -> +Lemma inst_frame_correct i wframe old1 old2: forall m tmp1 tmp2, + (disjoint (inst_frame i) wframe) -> (forall x, notIn x wframe -> old1 x = old2 x) -> (forall x, notIn x wframe -> tmp1 x = tmp2 x) -> - macro_prun ge i m tmp1 old1 = macro_prun ge i m tmp2 old2. + inst_prun ge i m tmp1 old1 = inst_prun ge i m tmp2 old2. Proof. induction i as [|[x e] i']; simpl; auto. intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. @@ -515,8 +515,8 @@ Fixpoint pararec (p: bblock) (wframe: list R.t): Prop := match p with | nil => True | i::p' => - disjoint (macro_frame i) wframe (* no USE-AFTER-WRITE *) - /\ pararec p' ((macro_wframe i) ++ wframe) + disjoint (inst_frame i) wframe (* no USE-AFTER-WRITE *) + /\ pararec p' ((inst_wframe i) ++ wframe) end. Lemma pararec_disjoint (p: bblock): forall wframe, pararec p wframe -> disjoint (bblock_wframe p) wframe. @@ -527,7 +527,7 @@ Proof. generalize (IHp' _ H1). rewrite disjoint_app_r. intuition. eapply disjoint_incl_l. 2: eapply H0. - unfold incl. eapply macro_wframe_frame; eauto. + unfold incl. eapply inst_wframe_frame; eauto. Qed. Lemma pararec_det p: forall wframe, pararec p wframe -> is_det p. @@ -546,13 +546,13 @@ Lemma pararec_correct p old: forall wframe m, Proof. elim p; clear p; simpl; auto. intros i p' X wframe m [H H0] H1. - erewrite macro_run_prun, macro_frame_correct; eauto. - remember (macro_prun ge i m old old) as om0. + erewrite inst_run_prun, inst_frame_correct; eauto. + remember (inst_prun ge i m old old) as om0. destruct om0 as [m0 | ]; try congruence. eapply X; eauto. intro x; rewrite notIn_app. intros [H3 H4]. rewrite <- H1; auto. - eapply macro_wframe_correct; eauto. + eapply inst_wframe_correct; eauto. Qed. Definition parallelizable (p: bblock) := pararec p nil. @@ -576,9 +576,9 @@ End PARALLELI. End ParallelizablityChecking. -Module Type ResourceSet. +Module Type PseudoRegSet. -Declare Module R: ResourceNames. +Declare Module R: PseudoRegisters. (** We assume a datatype [t] refining (list R.t) @@ -602,7 +602,7 @@ Parameter union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_fram Parameter is_disjoint: t -> t -> bool. Parameter is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. -End ResourceSet. +End PseudoRegSet. Lemma lazy_andb_bool_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. @@ -613,7 +613,7 @@ Qed. -Module ParallelChecks (L: SeqLanguage) (S:ResourceSet with Module R:=L.LP.R). +Module ParallelChecks (L: SeqLanguage) (S:PseudoRegSet with Module R:=L.LP.R). Include ParallelizablityChecking L. @@ -624,13 +624,13 @@ Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.i (** Now, refinement of each operation toward parallelizable *) -Fixpoint macro_wsframe(i:macro): S.t := +Fixpoint inst_wsframe(i:inst): S.t := match i with | nil => S.empty - | a::i' => S.add (fst a) (macro_wsframe i') + | a::i' => S.add (fst a) (inst_wsframe i') end. -Lemma macro_wsframe_correct i: S.match_frame (macro_wsframe i) (macro_wframe i). +Lemma inst_wsframe_correct i: S.match_frame (inst_wsframe i) (inst_wframe i). Proof. induction i; simpl; auto. Qed. @@ -653,27 +653,27 @@ Proof. induction e using exp_mut with (P0:=fun l => S.match_frame (list_exp_sframe l) (list_exp_frame l)); simpl; auto. Qed. -Fixpoint macro_sframe (i: macro): S.t := +Fixpoint inst_sframe (i: inst): S.t := match i with | nil => S.empty - | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (macro_sframe i')) + | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) end. Local Hint Resolve exp_sframe_correct. -Lemma macro_sframe_correct i: S.match_frame (macro_sframe i) (macro_frame i). +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 macro_wsframe_correct macro_sframe_correct. +Local Hint Resolve inst_wsframe_correct inst_sframe_correct. Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := match p with | nil => true | i::p' => - S.is_disjoint (macro_sframe i) wsframe (* no USE-AFTER-WRITE *) - &&& is_pararec p' (S.union (macro_wsframe i) wsframe) + S.is_disjoint (inst_sframe i) wsframe (* no USE-AFTER-WRITE *) + &&& is_pararec p' (S.union (inst_wsframe i) wsframe) end. Lemma is_pararec_correct (p: bblock): forall s l, S.match_frame s l -> (is_pararec p s)=true -> (pararec p l). @@ -706,7 +706,7 @@ End ParallelChecks. Require Import PArith. Require Import MSets.MSetPositive. -Module PosResourceSet <: ResourceSet with Module R:=Pos. +Module PosPseudoRegSet <: PseudoRegSet with Module R:=Pos. Module R:=Pos. @@ -776,4 +776,4 @@ Proof. intros H4 H5; eapply is_disjoint_spec_true; eauto. Qed. -End PosResourceSet. +End PosPseudoRegSet. -- cgit From 0c95673ef97195eae6213db92c2f69ef1d1ff48e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 1 Apr 2019 18:16:05 +0200 Subject: Started to add addressing with register + register, Mach -> Asm not done yet --- mppa_k1c/Op.v | 11 ++++++++--- mppa_k1c/PrintOp.ml | 1 + mppa_k1c/SelectOp.vp | 1 + mppa_k1c/SelectOpproof.v | 1 + mppa_k1c/ValueAOp.v | 1 + 5 files changed, 12 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c4338857..d533a504 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -187,6 +187,7 @@ Inductive operation : Type := addressing. *) Inductive addressing: Type := + | Aindexed2: addressing (**r Address is [r1 + r2] *) | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) @@ -385,6 +386,7 @@ Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with + | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) | Ainstack n, nil => Some (Val.offset_ptr sp n) @@ -569,6 +571,7 @@ Definition type_of_operation (op: operation) : list typ * typ := Definition type_of_addressing (addr: addressing) : list typ := match addr with + | Aindexed2 => Tptr :: Tptr :: nil | Aindexed _ => Tptr :: nil | Aglobal _ _ => nil | Ainstack _ => nil @@ -914,6 +917,7 @@ Qed. Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := match addr with + | Aindexed2 => None | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) @@ -1337,9 +1341,10 @@ Lemma eval_addressing_inj: exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. - apply Val.offset_ptr_inject; auto. - apply H; simpl; auto. - apply Val.offset_ptr_inject; auto. + - apply Val.addl_inject; auto. + - apply Val.offset_ptr_inject; auto. + - apply H; simpl; auto. + - apply Val.offset_ptr_inject; auto. Qed. End EVAL_COMPAT. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 9ec474b3..5ac00404 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -160,6 +160,7 @@ let print_operation reg pp = function let print_addressing reg pp = function | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) + | Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 | 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/SelectOp.vp b/mppa_k1c/SelectOp.vp index f6605c11..d82fe238 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -481,6 +481,7 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code 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:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) | _ => (Aindexed Ptrofs.zero, e:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 89af39ee..d426e4f1 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -991,6 +991,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. + - 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. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index fb1977ea..a54dbd8f 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -36,6 +36,7 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := match addr, vl with | Aindexed n, v1::nil => offset_ptr v1 n + | Aindexed2, v1::v2::nil => addl v1 v2 | Aglobal s ofs, nil => Ptr (Gl s ofs) | Ainstack ofs, nil => Ptr (Stk ofs) | _, _ => Vbot -- cgit From b8f03b19adda37c1c3275ef30d7fc106d3c97e44 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 18:34:22 +0200 Subject: renommage abstractbb: Name -> PReg --- mppa_k1c/Asmblockdeps.v | 50 ++++++++++++++-------------- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 6 ++-- mppa_k1c/abstractbb/DepTreeTheory.v | 2 +- mppa_k1c/abstractbb/ImpDep.v | 2 +- mppa_k1c/abstractbb/Parallelizability.v | 4 +-- 5 files changed, 32 insertions(+), 32 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 7043bd32..cc8f13f6 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -544,15 +544,15 @@ Notation "a @ b" := (Econs a b) (at level 102, right associativity). Definition trans_control (ctl: control) : inst := match ctl with - | Pret => [(#PC, Name (#RA))] - | Pcall s => [(#RA, Name (#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] - | Picall r => [(#RA, Name (#PC)); (#PC, Name (#r))] + | Pret => [(#PC, PReg(#RA))] + | Pcall s => [(#RA, PReg(#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] + | Picall r => [(#RA, PReg(#PC)); (#PC, PReg(#r))] | Pgoto s => [(#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] - | Pigoto r => [(#PC, Name (#r))] - | Pj_l l => [(#PC, Op (Control (Oj_l l)) (Name (#PC) @ Enil))] - | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (Name (#r) @ Name (#PC) @ Enil))] - | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (Name (#r) @ Name (#PC) @ Enil))] - | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (Name (#r) @ Name (#PC) @ Enil)); + | Pigoto r => [(#PC, PReg(#r))] + | Pj_l l => [(#PC, Op (Control (Oj_l l)) (PReg(#PC) @ Enil))] + | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (PReg(#r) @ PReg(#PC) @ Enil)); (#GPR62, Op (Constant Vundef) Enil); (#GPR63, Op (Constant Vundef) Enil) ] | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] @@ -568,36 +568,36 @@ Definition trans_exit (ex: option control) : L.inst := Definition trans_arith (ai: ar_instruction) : inst := match ai with | PArithR n d => [(#d, Op (Arith (OArithR n)) Enil)] - | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (Name (#s) @ Enil))] + | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (PReg(#s) @ Enil))] | PArithRI32 n d i => [(#d, Op (Arith (OArithRI32 n i)) Enil)] | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] - | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (Name (#s1) @ Name (#s2) @ Enil))] - | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (Name (#s) @ Enil))] - | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (Name (#s) @ Enil))] - | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (Name(#d) @ Name (#s1) @ Name (#s2) @ Enil))] - | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (Name(#d) @ Name (#s) @ Enil))] - | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (Name(#d) @ Name (#s) @ Enil))] + | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (PReg(#s1) @ PReg(#s2) @ Enil))] + | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (PReg(#s) @ Enil))] + | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (PReg(#s) @ Enil))] + | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (PReg(#d) @ PReg(#s1) @ PReg(#s2) @ Enil))] + | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (PReg(#d) @ PReg(#s) @ Enil))] + | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (PReg(#d) @ PReg(#s) @ Enil))] end. 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)) (Name (#a) @ Name pmem @ Enil))] - | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (Name (#s) @ Name (#a) @ Name pmem @ Enil))] - | Pallocframe sz pos => [(#FP, Name (#SP)); (#SP, Op (Allocframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); - (pmem, Op (Allocframe sz pos) (Old (Name (#SP)) @ Name pmem @ Enil))] - | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); - (#SP, Op (Freeframe2 sz pos) (Name (#SP) @ Old (Name pmem) @ Enil)); + | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (PReg(#a) @ PReg pmem @ Enil))] + | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg(#s) @ PReg(#a) @ PReg pmem @ Enil))] + | Pallocframe sz pos => [(#FP, PReg(#SP)); (#SP, Op (Allocframe2 sz pos) (PReg(#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); + (pmem, Op (Allocframe sz pos) (Old (PReg(#SP)) @ PReg pmem @ Enil))] + | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg(#SP) @ PReg pmem @ Enil)); + (#SP, Op (Freeframe2 sz pos) (PReg(#SP) @ Old (PReg pmem) @ Enil)); (#RTMP, Op (Constant Vundef) Enil)] | Pget rd ra => match ra with - | RA => [(#rd, Name (#ra))] + | RA => [(#rd, PReg(#ra))] | _ => [(#rd, Op Fail Enil)] end | Pset ra rd => match ra with - | RA => [(#ra, Name (#rd))] + | RA => [(#ra, PReg(#rd))] | _ => [(#rd, Op Fail Enil)] end | Pnop => [] @@ -609,7 +609,7 @@ Fixpoint trans_body (b: list basic) : list L.inst := | b :: lb => (trans_basic b) :: (trans_body lb) end. -Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (Name (#PC) @ Enil)) :: k. +Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (PReg(#PC) @ Enil)) :: k. Definition trans_block (b: Asmblock.bblock) : L.bblock := trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). @@ -1044,7 +1044,7 @@ Lemma exec_trans_pcincr_exec_instrun: forall rs m s b k, match_states (State rs m) s -> exists s', - inst_run Ge ((# PC, Op (OIncremPC (size b)) (Name (# PC) @ Enil)) :: k) s s = inst_run Ge k s' s + inst_run Ge ((# PC, Op (OIncremPC (size b)) (PReg(# PC) @ Enil)) :: k) s s = inst_run Ge k s' s /\ match_states (State (nextblock b rs) m) s'. Proof. intros. inv H. eexists. split. simpl. pose (H1 PC); simpl in e; rewrite e. destruct Ge. simpl. eapply eq_refl. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 0bab9426..3023ad8a 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -55,18 +55,18 @@ Definition assign (m: mem) (x:R.t) (v: value): mem := fun y => if R.eq_dec x y then v else m y. Inductive exp := - | Name (x:R.t) + | PReg (x:R.t) | Op (o:op) (le: list_exp) | Old (e: exp) with list_exp := | Enil | Econs (e:exp) (le:list_exp) | LOld (le: list_exp) - . +. Fixpoint exp_eval (e: exp) (m old: mem): option value := match e with - | Name x => Some (m x) + | PReg x => Some (m x) | Op o le => match list_exp_eval le m old with | Some lv => op_eval ge o lv diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index 4d5c71b3..bfe79d42 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -115,7 +115,7 @@ Hint Rewrite set_spec_eq empty_spec: dict_rw. Fixpoint exp_tree (e: exp) (d old: deps): tree := match e with - | Name x => deps_get d x + | 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 diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 3cc85fd5..a4dd12eb 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -171,7 +171,7 @@ Hint Resolve hdeps_get_correct: wlp. Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree := match e with - | Name x => hdeps_get d x dbg + | PReg x => hdeps_get d x dbg | Op o le => DO lt <~ hlist_exp_tree le d od;; hTop o lt dbg diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 519e7e54..d1971e57 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -455,7 +455,7 @@ Qed. Fixpoint exp_frame (e: exp): list R.t := match e with - | Name x => x::nil + | PReg x => x::nil | Op o le => list_exp_frame le | Old e => exp_frame e end @@ -637,7 +637,7 @@ Qed. Fixpoint exp_sframe (e: exp): S.t := match e with - | Name x => S.add x S.empty + | PReg x => S.add x S.empty | Op o le => list_exp_sframe le | Old e => exp_sframe e end -- cgit From 920bdebcd25c5b93142eab2a79e294e23ce6437d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 1 Apr 2019 19:51:21 +0200 Subject: Impure: improved iandb + struct_eq --- mppa_k1c/Asmblockdeps.v | 48 ++++++++++++--------------------- mppa_k1c/abstractbb/Impure/ImpCore.v | 10 ++++++- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 4 +-- 3 files changed, 28 insertions(+), 34 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index cc8f13f6..c941e482 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -291,12 +291,6 @@ Proof. destruct o; simpl; try congruence. Qed. - -Definition iandb (ib1 ib2: ?? bool): ?? bool := - DO b1 <~ ib1;; - DO b2 <~ ib2;; - RET (andb b1 b2). - Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o1 with | OArithR n1 => @@ -325,14 +319,15 @@ Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o2 with OArithARRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end end. +Ltac my_wlp_simplify := wlp_xsimplify ltac:(intros; subst; simpl in * |- *; congruence || intuition eauto with wlp). + Lemma arith_op_eq_correct o1 o2: WHEN arith_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. - destruct o1, o2; wlp_simplify; try discriminate. - all: try congruence. - all: apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + destruct o1, o2; my_wlp_simplify; try congruence. Qed. - +Hint Resolve arith_op_eq_correct: wlp. +Opaque arith_op_eq_correct. Definition load_op_eq (o1 o2: load_op): ?? bool := match o1, o2 with @@ -342,9 +337,10 @@ Definition load_op_eq (o1 o2: load_op): ?? bool := 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. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + destruct o1, o2; wlp_simplify; try congruence. Qed. +Hint Resolve load_op_eq_correct: wlp. +Opaque load_op_eq_correct. Definition store_op_eq (o1 o2: store_op): ?? bool := @@ -355,9 +351,10 @@ Definition store_op_eq (o1 o2: store_op): ?? bool := Lemma store_op_eq_correct o1 o2: WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. - destruct o1, o2; wlp_simplify. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + destruct o1, o2; wlp_simplify; try congruence. Qed. +Hint Resolve store_op_eq_correct: wlp. +Opaque store_op_eq_correct. (* TODO: rewrite control_op_eq in a robust style against the miss of a case cf. arith_op_eq above *) @@ -377,13 +374,10 @@ Definition control_op_eq (c1 c2: control_op): ?? bool := Lemma control_op_eq_correct c1 c2: WHEN control_op_eq c1 c2 ~> b THEN b = true -> c1 = c2. Proof. - destruct c1, c2; wlp_simplify; try discriminate. - - congruence. - - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. - - rewrite Z.eqb_eq in * |-. congruence. - - congruence. + destruct c1, c2; wlp_simplify; try rewrite Z.eqb_eq in * |-; try congruence. Qed. +Hint Resolve control_op_eq_correct: wlp. +Opaque control_op_eq_correct. (* TODO: rewrite op_eq in a robust style against the miss of a case @@ -403,21 +397,13 @@ Definition op_eq (o1 o2: op): ?? bool := | _, _ => RET false end. - Theorem op_eq_correct o1 o2: WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. Proof. - destruct o1, o2; wlp_simplify; try discriminate. - - simpl in Hexta. exploit arith_op_eq_correct. eassumption. eauto. congruence. - - simpl in Hexta. exploit load_op_eq_correct. eassumption. eauto. congruence. - - simpl in Hexta. exploit store_op_eq_correct. eassumption. eauto. congruence. - - simpl in Hexta. exploit control_op_eq_correct. eassumption. eauto. congruence. - - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. - - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. - - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. - - apply andb_prop in H0; inversion_clear H0. apply H in H2. apply Z.eqb_eq in H1. congruence. - - congruence. + destruct o1, o2; wlp_simplify; try rewrite Z.eqb_eq in * |- ; try congruence. Qed. +Hint Resolve op_eq_correct: wlp. +Global Opaque op_eq_correct. (* QUICK FIX WITH struct_eq *) diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index 6eb0c5af..9745e35c 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -132,6 +132,7 @@ Proof. destruct x; simpl; auto. Qed. + (* Tactics MAIN tactics: @@ -184,4 +185,11 @@ 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). + +(* impure lazy andb of booleans *) +Definition iandb (k1 k2: ??bool): ?? bool := + DO r1 <~ k1 ;; + if r1 then k2 else RET false. + +Extraction Inline iandb. (* Juste pour l'efficacité à l'extraction ! *) \ No newline at end of file diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index e7c7a9fb..8d904be6 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -77,14 +77,14 @@ Qed. End PhysEqModel. - Export PhysEqModel. Extract Constant phys_eq => "(==)". Hint Resolve phys_eq_correct: wlp. + Axiom struct_eq: forall {A}, A -> A -> ?? bool. -Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN b=true -> x=y. +Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN if b then x=y else x<>y. Extract Constant struct_eq => "(=)". Hint Resolve struct_eq_correct: wlp. -- cgit From 014b2c474be0126a8a09f7138365d555c29af4a4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 2 Apr 2019 07:26:58 +0200 Subject: comment on Asmblockdeps.is_constant --- mppa_k1c/Asmblockdeps.v | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c941e482..e3e2bca9 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -270,25 +270,28 @@ Definition op_eval (o: op) (l: list value) := end. -Definition is_constant (o: op): bool := - (* FIXME + (** 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. - => répondre "true" autant que possible mais en satisfaisant [is_constant_correct] ci-dessous. + 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] - ATTENTION, is_constant ne doit pas dépendre de [ge]. - Sinon, on aurait une implémentation facile: [match op_eval o nil with Some _ => true | _ => false end] - - => REM: il n'est pas sûr que ce soit utile de faire qqchose de très exhaustif en pratique... - (ça sert juste à une petite optimisation du vérificateur de scheduling). + => 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 _ => true + | 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 := -- cgit From 2e54a0fe8111e473361f9c1ab44b5d1cf9d70020 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 2 Apr 2019 07:53:34 +0200 Subject: robustness of Asmblockdeps.*op_eq --- mppa_k1c/Asmblockdeps.v | 65 +++++++++++++++++++++++++++++-------------------- 1 file changed, 38 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e3e2bca9..6d87a34d 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -359,19 +359,24 @@ Qed. Hint Resolve store_op_eq_correct: wlp. Opaque store_op_eq_correct. -(* TODO: rewrite control_op_eq in a robust style against the miss of a case - cf. arith_op_eq above *) Definition control_op_eq (c1 c2: control_op): ?? bool := - match c1, c2 with - | Oj_l l1, Oj_l l2 => phys_eq l1 l2 - | Ocb bt1 l1, Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) - | Ocbu bt1 l1, Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) - | Ojumptable tbl1, Ojumptable tbl2 => phys_eq tbl1 tbl2 - | Odiv, Odiv => RET true - | Odivu, Odivu => RET true - | OIncremPC sz1, OIncremPC sz2 => RET (Z.eqb sz1 sz2) - | OError, OError => RET true - | _, _ => RET false + match c1 with + | Oj_l l1 => + match c2 with Oj_l l2 => phys_eq l1 l2 | _ => RET false end + | Ocb bt1 l1 => + match c2 with Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end + | Ocbu bt1 l1 => + match c2 with Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end + | Ojumptable tbl1 => + match c2 with Ojumptable tbl2 => phys_eq tbl1 tbl2 | _ => RET false end + | Odiv => + match c2 with Odiv => RET true | _ => RET false end + | Odivu => + match c2 with Odivu => RET true | _ => RET false end + | OIncremPC sz1 => + match c2 with OIncremPC sz2 => RET (Z.eqb sz1 sz2) | _ => RET false end + | OError => + match c2 with OError => RET true | _ => RET false end end. Lemma control_op_eq_correct c1 c2: @@ -382,22 +387,28 @@ Qed. Hint Resolve control_op_eq_correct: wlp. Opaque control_op_eq_correct. - -(* TODO: rewrite op_eq in a robust style against the miss of a case - cf. arith_op_eq above *) Definition op_eq (o1 o2: op): ?? bool := - match o1, o2 with - | Arith i1, Arith i2 => arith_op_eq i1 i2 - | Load i1, Load i2 => load_op_eq i1 i2 - | Store i1, Store i2 => store_op_eq i1 i2 - | Control i1, Control i2 => control_op_eq i1 i2 - | Allocframe sz1 pos1, Allocframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) - | Allocframe2 sz1 pos1, Allocframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) - | Freeframe sz1 pos1, Freeframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) - | Freeframe2 sz1 pos1, Freeframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) - | Constant c1, Constant c2 => phys_eq c1 c2 - | Fail, Fail => RET true - | _, _ => RET false + match o1 with + | Arith i1 => + match o2 with Arith i2 => arith_op_eq i1 i2 | _ => RET false end + | Load i1 => + match o2 with Load i2 => load_op_eq i1 i2 | _ => RET false end + | Store i1 => + match o2 with Store i2 => store_op_eq i1 i2 | _ => RET false end + | Control i1 => + match o2 with Control i2 => control_op_eq i1 i2 | _ => RET false end + | Allocframe sz1 pos1 => + match o2 with Allocframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Allocframe2 sz1 pos1 => + match o2 with Allocframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Freeframe sz1 pos1 => + match o2 with Freeframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Freeframe2 sz1 pos1 => + match o2 with Freeframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Constant c1 => + match o2 with Constant c2 => phys_eq c1 c2 | _ => RET false end + | Fail => + match o2 with Fail => RET true | _ => RET false end end. Theorem op_eq_correct o1 o2: -- cgit From 4adb0af96c3c0523438e86275f9e23ffdc69e4ba Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 2 Apr 2019 17:37:09 +0200 Subject: Added definition of PLoadRRR and PStoreRRR - no Asmblockgen generation yet --- mppa_k1c/Asm.v | 97 +++++++++------ mppa_k1c/Asmblock.v | 52 +++++--- mppa_k1c/Asmblockdeps.v | 226 +++++++++++++++++++++++++---------- mppa_k1c/Asmblockgenproof1.v | 25 ++-- mppa_k1c/Asmexpand.ml | 44 +++---- mppa_k1c/Asmvliw.v | 48 +++++--- mppa_k1c/PostpassSchedulingOracle.ml | 4 + mppa_k1c/PostpassSchedulingproof.v | 64 +++++++--- mppa_k1c/TargetPrinter.ml | 44 +++---- mppa_k1c/lib/Asmblockgenproof0.v | 18 +-- 10 files changed, 417 insertions(+), 205 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 2d708b79..115c8d6d 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -38,6 +38,11 @@ Require Import Errors. Definition label := positive. Definition preg := preg. +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) +. + (** Syntax *) Inductive instruction : Type := (** pseudo instructions *) @@ -70,26 +75,26 @@ Inductive instruction : Type := | Ploopdo (count: ireg) (loopend: label) (** Loads **) - | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *) + | 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 *) (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *) - | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *) + | 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 (rd: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) (** Arith RR *) | Pmv (rd rs: ireg) (**r register move *) @@ -364,26 +369,46 @@ Definition basic_to_instruction (b: basic) := | PArithARRI64 Asmblock.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm (** Load *) - | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs - | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra ofs - | PLoadRRO Asmblock.Plh rd ra ofs => Plh rd ra ofs - | PLoadRRO Asmblock.Plhu rd ra ofs => Plhu rd ra ofs - | PLoadRRO Asmblock.Plw rd ra ofs => Plw rd ra ofs - | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra ofs - | PLoadRRO Asmblock.Pld rd ra ofs => Pld rd ra ofs - | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra ofs - | PLoadRRO Asmblock.Pfls rd ra ofs => Pfls rd ra ofs - | PLoadRRO Asmblock.Pfld rd ra ofs => Pfld rd ra ofs + | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra (AOff ofs) + | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra (AOff ofs) + | PLoadRRO Asmblock.Plh rd ra ofs => Plh rd ra (AOff ofs) + | PLoadRRO Asmblock.Plhu rd ra ofs => Plhu rd ra (AOff ofs) + | PLoadRRO Asmblock.Plw rd ra ofs => Plw rd ra (AOff ofs) + | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) + | PLoadRRO Asmblock.Pld rd ra ofs => Pld rd ra (AOff ofs) + | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) + | PLoadRRO Asmblock.Pfls rd ra ofs => Pfls rd ra (AOff ofs) + | PLoadRRO Asmblock.Pfld rd ra ofs => Pfld rd ra (AOff ofs) + + | PLoadRRR Asmblock.Plb rd ra ro => Plb rd ra (AReg ro) + | PLoadRRR Asmblock.Plbu rd ra ro => Plbu rd ra (AReg ro) + | PLoadRRR Asmblock.Plh rd ra ro => Plh rd ra (AReg ro) + | PLoadRRR Asmblock.Plhu rd ra ro => Plhu rd ra (AReg ro) + | PLoadRRR Asmblock.Plw rd ra ro => Plw rd ra (AReg ro) + | PLoadRRR Asmblock.Plw_a rd ra ro => Plw_a rd ra (AReg ro) + | PLoadRRR Asmblock.Pld rd ra ro => Pld rd ra (AReg ro) + | PLoadRRR Asmblock.Pld_a rd ra ro => Pld_a rd ra (AReg ro) + | PLoadRRR Asmblock.Pfls rd ra ro => Pfls rd ra (AReg ro) + | PLoadRRR Asmblock.Pfld rd ra ro => Pfld rd ra (AReg ro) (** Store *) - | PStoreRRO Asmblock.Psb rd ra ofs => Psb rd ra ofs - | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra ofs - | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra ofs - | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra ofs - | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra ofs - | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra ofs - | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra ofs - | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfsd rd ra ofs + | PStoreRRO Asmblock.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmblock.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmblock.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmblock.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmblock.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmblock.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmblock.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmblock.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmblock.Pfsd rd ra ro => Pfsd rd ra (AReg ro) end. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index b4cf57ae..3656b91f 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -259,9 +259,11 @@ Inductive load_name_rro : Type := Inductive ld_instruction : Type := | PLoadRRO (i: load_name_rro) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (i: load_name_rro) (rd: ireg) (ra: ireg) (rofs: ireg) . Coercion PLoadRRO: load_name_rro >-> Funclass. +Coercion PLoadRRR: load_name_rro >-> Funclass. (** Stores **) Inductive store_name_rro : Type := @@ -277,9 +279,11 @@ Inductive store_name_rro : Type := Inductive st_instruction : Type := | PStoreRRO (i: store_name_rro) (rs: ireg) (ra: ireg) (ofs: offset) + | PStoreRRR (i: store_name_rro) (rs: ireg) (ra: ireg) (rofs: ireg) . Coercion PStoreRRO: store_name_rro >-> Funclass. +Coercion PStoreRRR: store_name_rro >-> Funclass. (** Arithmetic instructions **) Inductive arith_name_r : Type := @@ -1259,24 +1263,42 @@ Definition eval_offset (ofs: offset) : res ptrofs := end. Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) - (d: ireg) (a: ireg) (ofs: offset) := + (d: ireg) (a: ireg) (ptr: ptrofs) := + match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with + | None => Stuck + | Some v => Next (rs#d <- v) m + end +. + +Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := match (eval_offset ofs) with - | OK ptr => - match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with - | None => Stuck - | Some v => Next (rs#d <- v) m - end + | OK ptr => exec_load chunk rs m d a ptr + | _ => Stuck + end. + +Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := + match (rs ro) with + | Vptr _ ofs => exec_load chunk rs m d a ofs | _ => Stuck end. Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) - (s: ireg) (a: ireg) (ofs: offset) := + (s: ireg) (a: ireg) (ptr: ptrofs) := + match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with + | None => Stuck + | Some m' => Next rs m' + end +. + +Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := match (eval_offset ofs) with - | OK ptr => - match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with - | None => Stuck - | Some m' => Next rs m' - end + | OK ptr => exec_store chunk rs m s a ptr + | _ => Stuck + end. + +Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := + match (rs ro) with + | Vptr _ ofs => exec_store chunk rs m s a ofs | _ => Stuck end. @@ -1312,9 +1334,11 @@ Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := match bi with | PArith ai => Next (exec_arith_instr ai rs) m - | PLoadRRO n d a ofs => exec_load (load_chunk n) rs m d a ofs + | PLoadRRO n d a ofs => exec_load_offset (load_chunk n) rs m d a ofs + | PLoadRRR n d a ro => exec_load_reg (load_chunk n) rs m d a ro - | PStoreRRO n s a ofs => exec_store (store_chunk n) rs m s a ofs + | PStoreRRO n s a ofs => exec_store_offset (store_chunk n) rs m s a ofs + | PStoreRRR n s a ro => exec_store_reg (store_chunk n) rs m s a ro | Pallocframe sz pos => let (m1, stk) := Mem.alloc m 0 sz in diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index dd876485..7e332895 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -72,12 +72,14 @@ Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := | OLoadRRO (n: load_name_rro) (ofs: offset) + | OLoadRRR (n: load_name_rro) . Coercion OLoadRRO: load_name_rro >-> Funclass. Inductive store_op := | OStoreRRO (n: store_name_rro) (ofs: offset) + | OStoreRRR (n: store_name_rro) . Coercion OStoreRRO: store_name_rro >-> Funclass. @@ -126,38 +128,58 @@ Definition arith_eval (ao: arith_op) (l: list value) := end. Definition exec_load_deps (chunk: memory_chunk) (m: mem) - (v: val) (ofs: offset) := + (v: val) (ptr: ptrofs) := + match Mem.loadv chunk m (Val.offset_ptr v ptr) with + | None => None + | Some vl => Some (Val vl) + end +. + +Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ge ofs) with - | OK ptr => - match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => None - | Some vl => Some (Val vl) - end + | OK ptr => exec_load_deps chunk m v ptr + | _ => None + end. + +Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := + match vo with + | Vptr _ ofs => exec_load_deps chunk m v ofs | _ => None end. Definition load_eval (lo: load_op) (l: list value) := match lo, l with - | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps (load_chunk n) m v ofs + | 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 | _, _ => None end. Definition exec_store_deps (chunk: memory_chunk) (m: mem) - (vs va: val) (ofs: offset) := + (vs va: val) (ptr: ptrofs) := + match Mem.storev chunk m (Val.offset_ptr va ptr) vs with + | None => None + | Some m' => Some (Memstate m') + end +. + +Definition exec_store_deps_offset (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ge ofs) with - | OK ptr => - match Mem.storev chunk m (Val.offset_ptr va ptr) vs with - | None => None - | Some m' => Some (Memstate m') - end + | OK ptr => exec_store_deps chunk m vs va ptr + | _ => None + end. + +Definition exec_store_deps_reg (chunk: memory_chunk) (m: mem) (vs va vo: val) := + match vo with + | Vptr _ ofs => exec_store_deps chunk m vs va ofs | _ => None end. Definition store_eval (so: store_op) (l: list value) := match so, l with - | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps (store_chunk n) m vs va ofs + | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps_offset (store_chunk n) m vs va ofs + | OStoreRRR n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_reg (store_chunk n) m vs va vo | _, _ => None end. @@ -337,26 +359,32 @@ Qed. Definition load_op_eq (o1 o2: load_op): ?? bool := match o1, o2 with | OLoadRRO n1 ofs1, OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) + | OLoadRRR n1, OLoadRRR n2 => phys_eq n1 n2 + | _, _ => RET false 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. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + destruct o1, o2; wlp_simplify; try discriminate. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - congruence. Qed. Definition store_op_eq (o1 o2: store_op): ?? bool := match o1, o2 with | OStoreRRO n1 ofs1, OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) + | OStoreRRR n1, OStoreRRR n2 => phys_eq n1 n2 + | _, _ => RET false end. Lemma store_op_eq_correct o1 o2: WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. - destruct o1, o2; wlp_simplify. - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + destruct o1, o2; wlp_simplify; try discriminate. + - apply andb_prop in H1; inversion H1; apply H in H2; apply H0 in H3; congruence. + - congruence. Qed. (* TODO: rewrite control_op_eq in a robust style against the miss of a case @@ -586,7 +614,9 @@ Definition trans_basic (b: basic) : macro := match b with | PArith ai => trans_arith ai | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (Name (#a) @ Name pmem @ Enil))] + | PLoadRRR n d a ro => [(#d, Op (Load (OLoadRRR n)) (Name (#a) @ Name (#ro) @ Name pmem @ Enil))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (Name (#s) @ Name (#a) @ Name pmem @ Enil))] + | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (Name (#s) @ Name (#a) @ Name (#ro) @ Name pmem @ Enil))] | Pallocframe sz pos => [(#FP, Name (#SP)); (#SP, Op (Allocframe2 sz pos) (Name (#SP) @ Name pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (Name (#SP)) @ Name pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (Name (#SP) @ Name pmem @ Enil)); @@ -799,25 +829,47 @@ Proof. intros. destruct b. (* Arith *) - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. + (* Load *) - simpl in H. destruct i. - unfold exec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; pose (H1 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| - Simpl| - intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); [ - subst; Simpl| - Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. + (* Load Offset *) + + destruct i. all: + unfold exec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_load in H; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; [ + simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); unfold exec_load_deps; simpl in MEML; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + (* Load Reg *) + + destruct i. all: + unfold exec_load_reg in H; destruct (rs rofs) eqn:ROFS; try discriminate; unfold exec_load in H; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; [ + simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold exec_load_deps_reg; rewrite ROFS; + unfold exec_load_deps; simpl in MEML; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + (* Store *) - simpl in H. destruct i. - all: unfold exec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; pose (H1 ra); simpl in e; rewrite e; pose (H1 rs0); simpl in e0; rewrite e0; rewrite MEML; reflexivity - | Simpl - | intros rr; destruct rr; Simpl]. + (* Store Offset *) + + destruct i. all: + unfold exec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_store in H; + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps; simpl in MEML; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl ]. + (* Store Reg *) + + destruct i. all: + unfold exec_store_reg in H; destruct (rs rofs) eqn:ROFS; try discriminate; unfold exec_store in H; + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; + [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps_reg; rewrite ROFS; + unfold exec_store_deps; simpl in MEML; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl ]. + (* Allocframe *) - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. inv H. inv H0. eexists. split; try split. @@ -1155,13 +1207,28 @@ Lemma forward_simu_basic_instr_stuck: Proof. intros. inv H1. unfold exec_basic_instr in H0. destruct i; try discriminate. (* PLoad *) - - destruct i; destruct i. - all: simpl; rewrite H2; pose (H3 ra); simpl in e; rewrite e; clear e; - unfold exec_load in H0; destruct (eval_offset _ _); auto; destruct (Mem.loadv _ _ _); auto; discriminate. + - destruct i. + (* Load Offset *) + + destruct i. all: + simpl; rewrite H2; rewrite (H3 ra); unfold exec_load_offset in H0; destruct (eval_offset _ _); auto; + unfold exec_load in H0; unfold exec_load_deps; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. + (* Load Reg *) + + destruct i. all: + simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); unfold exec_load_reg in H0; unfold exec_load_deps_reg; + destruct (rs rofs); auto; unfold exec_load in H0; simpl in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + (* PStore *) - - destruct i; destruct i; - simpl; rewrite H2; pose (H3 ra); simpl in e; rewrite e; clear e; pose (H3 rs0); simpl in e; rewrite e; clear e; - unfold exec_store in H0; destruct (eval_offset _ _); auto; destruct (Mem.storev _ _ _); auto; discriminate. + - destruct i. + (* Store Offset *) + + destruct i. all: + simpl; rewrite H2; rewrite (H3 ra); rewrite (H3 rs0); unfold exec_store_offset in H0; destruct (eval_offset _ _); auto; + unfold exec_store in H0; simpl in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _); auto; discriminate. + (* Store Reg *) + + destruct i. all: + simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); rewrite (H3 rs0); simpl in H0; unfold exec_store_reg in H0; + unfold exec_store_deps_reg; destruct (rs rofs); auto; unfold exec_store in H0; unfold exec_store_deps; + destruct (Mem.storev _ _ _ _); auto; discriminate. + (* Pallocframe *) - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. destruct (Mem.alloc _ _ _). simpl in H0. destruct (Mem.store _ _ _ _); try discriminate. reflexivity. @@ -1521,6 +1588,7 @@ Definition string_of_name_lrro (n: load_name_rro) : pstring := Definition string_of_load (op: load_op): pstring := match op with | OLoadRRO n _ => string_of_name_lrro n + | OLoadRRR n => string_of_name_lrro n end. Definition string_of_name_srro (n: store_name_rro) : pstring := @@ -1538,6 +1606,7 @@ Definition string_of_name_srro (n: store_name_rro) : pstring := Definition string_of_store (op: store_op) : pstring := match op with | OStoreRRO n _ => string_of_name_srro n + | OStoreRRR n => string_of_name_srro n end. Definition string_of_control (op: control_op) : pstring := @@ -1731,23 +1800,46 @@ Proof. - simpl in H. inversion H. subst rsw' mw'. simpl macro_prun. eapply trans_arith_par_correct; eauto. (* Load *) - simpl in H. destruct i. - unfold parexec_load in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H. inv MSR; inv MSW; - eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; pose (H0 ra); simpl in e; rewrite e; rewrite MEML; reflexivity| - Simpl| - intros rr; destruct rr; Simpl; - destruct (ireg_eq g rd); [ - subst; Simpl| - Simpl; rewrite assign_diff; pose (H1 g); simpl in e; try assumption; Simpl; unfold ppos; apply not_eq_ireg_to_pos; assumption]]. + (* Load Offset *) + + destruct i; simpl load_chunk in H. all: + unfold parexec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + unfold parexec_load in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); unfold exec_load_deps; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + + (* Load Reg *) + + destruct i; simpl load_chunk in H. all: + unfold parexec_load_reg in H; destruct (rsr rofs) eqn:ROFS; try discriminate; + unfold parexec_load in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + eexists; split; try split; + [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); unfold exec_load_deps_reg; rewrite ROFS; + unfold exec_load_deps; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + (* Store *) - simpl in H. destruct i. - unfold parexec_store in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate. - destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate. inv H; inv MSR; inv MSW. - eexists; split; try split. - * simpl. rewrite EVALOFF. rewrite H. rewrite (H0 ra). rewrite (H0 rs). rewrite MEML. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. + (* Store Offset *) + + destruct i; simpl store_chunk in H. all: + unfold parexec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; + unfold parexec_store in H; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + eexists; split; try split; + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); rewrite (H0 rs); unfold exec_store_deps; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl ]. + + (* Store Reg *) + + destruct i; simpl store_chunk in H. all: + unfold parexec_store_reg in H; destruct (rsr rofs) eqn:ROFS; try discriminate; + unfold parexec_store in H; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + eexists; split; try split; + [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); rewrite (H0 rs); unfold exec_store_deps_reg; rewrite ROFS; + unfold exec_store_deps; rewrite MEML; reflexivity + | Simpl + | intros rr; destruct rr; Simpl ]. + (* Allocframe *) - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. inv H. inv MSR. inv MSW. eexists. split; try split. @@ -1785,13 +1877,27 @@ Proof. intros GENV MSR MSW H0. inv MSR; inv MSW. unfold parexec_basic_instr in H0. destruct bi; try discriminate. (* PLoad *) - - destruct i; destruct i. - all: simpl; rewrite H; rewrite (H1 ra); unfold parexec_load in H0; - destruct (eval_offset _ _); auto; destruct (Mem.loadv _ _ _); auto; discriminate. + - destruct i. + (* Load Offset *) + + destruct i; simpl in H0. all: + simpl; rewrite H; rewrite (H1 ra); unfold parexec_load_offset in H0; destruct (eval_offset _ _); auto; + unfold parexec_load in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + (* Load Reg *) + + destruct i; simpl in H0. all: + simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold parexec_load_reg in H0; unfold exec_load_deps_reg; + destruct (rsr rofs); auto; unfold parexec_load in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + (* PStore *) - - destruct i; destruct i; - simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); - unfold parexec_store in H0; destruct (eval_offset _ _); auto; destruct (Mem.storev _ _ _); auto; discriminate. + - destruct i. + (* Store Offset *) + + destruct i; simpl in H0. all: + simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); unfold parexec_store_offset in H0; destruct (eval_offset _ _); auto; + unfold parexec_store in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _ _); auto; discriminate. + + (* Store Reg *) + + destruct i; simpl in H0. all: + simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); rewrite (H1 rofs); unfold parexec_store_reg in H0; unfold exec_store_deps_reg; + destruct (rsr rofs); auto; unfold parexec_store in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _ _); auto; discriminate. (* Pallocframe *) - simpl. Simpl. rewrite (H1 SP). rewrite H. destruct (Mem.alloc _ _ _). simpl in H0. destruct (Mem.store _ _ _ _); try discriminate. reflexivity. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5486a497..f8bbf7f4 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1763,7 +1763,7 @@ Qed. Lemma indexed_load_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) rd m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset ge 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 -> base <> RTMP -> @@ -1777,14 +1777,14 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. + unfold exec_load_offset. rewrite PtrEq. unfold exec_load. rewrite B, LOAD. eauto. Simpl. split; intros; Simpl. auto. Qed. Lemma indexed_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) r1 m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> base <> RTMP -> r1 <> RTMP -> @@ -1797,12 +1797,11 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store. rewrite PtrEq. rewrite B, C, STORE. + unfold exec_store_offset. rewrite PtrEq. unfold exec_store. rewrite B, C, STORE. eauto. discriminate. { intro. inv H. contradiction. } auto. -(* intros; Simpl. rewrite C; auto. *) Qed. Lemma loadind_correct: @@ -1821,7 +1820,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 ge (chunk_of_type ty) rs' m rd base' ofs'). + exec_load_offset ge (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. @@ -1843,7 +1842,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_store ge (chunk_of_type ty) rs' m rr base' ofs'). + exec_store_offset ge (chunk_of_type ty) rs' m rr base' ofs'). { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; esplit; eauto. } destruct A as (mk_instr & rr & rsEq & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. @@ -1945,7 +1944,7 @@ Qed. Lemma transl_load_access_correct: forall 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 ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset ge 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' -> @@ -1959,14 +1958,14 @@ Proof. 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. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + rewrite INSTR. unfold exec_load_offset. unfold exec_load. rewrite PtrEq, B, LOAD. reflexivity. Simpl. split; intros; Simpl. auto. Qed. Lemma transl_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> @@ -1980,7 +1979,7 @@ Proof. 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_store. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. + rewrite INSTR. unfold exec_store_offset. unfold exec_store. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. intro. inv H. contradiction. auto. Qed. @@ -2000,7 +1999,7 @@ Proof. 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 ge chunk rs m rd base ofs). + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset ge chunk rs m rd base ofs). { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (esplit; eauto). } destruct A as (mk_instr & rd & rdEq & B & C). rewrite rdEq. eapply transl_load_access_correct; eauto with asmgen. @@ -2020,7 +2019,7 @@ Proof. preg_of src = IR rr /\ 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_store ge chunk' rs m rr base ofs) + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk' rs m rr base ofs) /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). { unfold transl_store in TR; destruct chunk; ArgsInv; (econstructor; econstructor; econstructor; split; [eauto | split; [eassumption | split; [ intros; simpl; reflexivity | auto]]]). diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index f1528389..a9f17f33 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -157,10 +157,10 @@ let expand_builtin_memcpy_big sz al src dst = let lbl = new_label() in emit (Ploopdo (tmpbuf, lbl)); emit Psemi; - emit (Plb (tmpbuf, srcptr, Asmblock.Ofsimm Z.zero)); + emit (Plb (tmpbuf, srcptr, AOff (Asmblock.Ofsimm Z.zero))); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; - emit (Psb (tmpbuf, dstptr, Asmblock.Ofsimm Z.zero)); + emit (Psb (tmpbuf, dstptr, AOff (Asmblock.Ofsimm Z.zero))); emit (Paddil (dstptr, dstptr, Z.one)); emit Psemi; emit (Plabel lbl);; @@ -176,30 +176,30 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk base ofs res = match chunk, res with | Mint8unsigned, BR(Asmblock.IR res) -> - emit (Plbu (res, base, Asmblock.Ofsimm ofs)) + emit (Plbu (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint8signed, BR(Asmblock.IR res) -> - emit (Plb (res, base, Asmblock.Ofsimm ofs)) + emit (Plb (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint16unsigned, BR(Asmblock.IR res) -> - emit (Plhu (res, base, Asmblock.Ofsimm ofs)) + emit (Plhu (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint16signed, BR(Asmblock.IR res) -> - emit (Plh (res, base, Asmblock.Ofsimm ofs)) + emit (Plh (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint32, BR(Asmblock.IR res) -> - emit (Plw (res, base, Asmblock.Ofsimm ofs)) + emit (Plw (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint64, BR(Asmblock.IR res) -> - emit (Pld (res, base, Asmblock.Ofsimm ofs)) + emit (Pld (res, base, AOff (Asmblock.Ofsimm ofs))) | Mint64, BR_splitlong(BR(Asmblock.IR res1), BR(Asmblock.IR res2)) -> let ofs' = Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, Asmblock.Ofsimm ofs)); - emit (Plw (res1, base, Asmblock.Ofsimm ofs')) + emit (Plw (res2, base, AOff (Asmblock.Ofsimm ofs))); + emit (Plw (res1, base, AOff (Asmblock.Ofsimm ofs'))) end else begin - emit (Plw (res1, base, Asmblock.Ofsimm ofs')); - emit (Plw (res2, base, Asmblock.Ofsimm ofs)) + emit (Plw (res1, base, AOff (Asmblock.Ofsimm ofs'))); + emit (Plw (res2, base, AOff (Asmblock.Ofsimm ofs))) end | Mfloat32, BR(Asmblock.IR res) -> - emit (Pfls (res, base, Asmblock.Ofsimm ofs)) + emit (Pfls (res, base, AOff (Asmblock.Ofsimm ofs))) | Mfloat64, BR(Asmblock.IR res) -> - emit (Pfld (res, base, Asmblock.Ofsimm ofs)) + emit (Pfld (res, base, AOff (Asmblock.Ofsimm ofs))) | _ -> assert false @@ -218,21 +218,21 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk base ofs src = match chunk, src with | (Mint8signed | Mint8unsigned), BA(Asmblock.IR src) -> - emit (Psb (src, base, Asmblock.Ofsimm ofs)) + emit (Psb (src, base, AOff (Asmblock.Ofsimm ofs))) | (Mint16signed | Mint16unsigned), BA(Asmblock.IR src) -> - emit (Psh (src, base, Asmblock.Ofsimm ofs)) + emit (Psh (src, base, AOff (Asmblock.Ofsimm ofs))) | Mint32, BA(Asmblock.IR src) -> - emit (Psw (src, base, Asmblock.Ofsimm ofs)) + emit (Psw (src, base, AOff (Asmblock.Ofsimm ofs))) | Mint64, BA(Asmblock.IR src) -> - emit (Psd (src, base, Asmblock.Ofsimm ofs)) + emit (Psd (src, base, AOff (Asmblock.Ofsimm ofs))) | Mint64, BA_splitlong(BA(Asmblock.IR src1), BA(Asmblock.IR src2)) -> let ofs' = Ptrofs.add ofs _4 in - emit (Psw (src2, base, Asmblock.Ofsimm ofs)); - emit (Psw (src1, base, Asmblock.Ofsimm ofs')) + emit (Psw (src2, base, AOff (Asmblock.Ofsimm ofs))); + emit (Psw (src1, base, AOff (Asmblock.Ofsimm ofs'))) | Mfloat32, BA(Asmblock.IR src) -> - emit (Pfss (src, base, Asmblock.Ofsimm ofs)) + emit (Pfss (src, base, AOff (Asmblock.Ofsimm ofs))) | Mfloat64, BA(Asmblock.IR src) -> - emit (Pfsd (src, base, Asmblock.Ofsimm ofs)) + emit (Pfsd (src, base, AOff (Asmblock.Ofsimm ofs))) | _ -> assert false diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index d553c612..cae79287 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -70,24 +70,42 @@ Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := (* TODO: factoriser ? *) Definition parexec_load (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) - (d: ireg) (a: ireg) (ofs: offset) := + (d: ireg) (a: ireg) (ptr: ptrofs) := + match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with + | None => Stuck + | Some v => Next (rsw#d <- v) mw + end +. + +Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := match (eval_offset ge ofs) with - | OK ptr => - match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => Stuck - | Some v => Next (rsw#d <- v) mw - end + | OK ptr => parexec_load chunk rsr rsw mr mw d a ptr + | _ => Stuck + end. + +Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := + match (rsr ro) with + | Vptr _ ofs => parexec_load chunk rsr rsw mr mw d a ofs | _ => Stuck end. Definition parexec_store (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) - (s: ireg) (a: ireg) (ofs: offset) := + (s: ireg) (a: ireg) (ptr: ptrofs) := + match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end +. + +Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := match (eval_offset ge ofs) with - | OK ptr => - match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with - | None => Stuck - | Some m' => Next rsw m' - end + | OK ptr => parexec_store chunk rsr rsw mr mw s a ptr + | _ => Stuck + end. + +Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := + match (rsr ro) with + | Vptr _ ofs => parexec_store chunk rsr rsw mr mw s a ofs | _ => Stuck end. @@ -100,9 +118,11 @@ Definition parexec_basic_instr (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 (load_chunk n) rsr rsw mr mw d a ofs + | 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 - | PStoreRRO n s a ofs => parexec_store (store_chunk n) rsr rsw mr mw s a ofs + | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs + | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro | Pallocframe sz pos => let (mw, stk) := Mem.alloc mr 0 sz in diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 62df124a..762c67fc 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -201,10 +201,14 @@ let arith_rec i = 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} + | PLoadRRR (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} 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} + | PStoreRRR (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} let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 4e33fc90..77014bdc 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -95,23 +95,47 @@ Proof. - repeat (rewrite Pregmap.gso); auto. Qed. -Lemma exec_load_pc_var: +Lemma exec_load_offset_pc_var: forall ge t rs m rd ra ofs rs' m' v, - exec_load ge t rs m rd ra ofs = Next rs' m' -> - exec_load ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + exec_load_offset ge t rs m rd ra ofs = Next rs' m' -> + exec_load_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. + intros. unfold exec_load_offset in *. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge 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_store_pc_var: +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 exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (rs ro); 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_store_offset_pc_var: forall ge t rs m rd ra ofs rs' m' v, - exec_store ge t rs m rd ra ofs = Next rs' m' -> - exec_store ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + exec_store_offset ge t rs m rd ra ofs = Next rs' m' -> + exec_store_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_offset in *. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. + destruct (eval_offset ge ofs); try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +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 in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. + intros. unfold exec_store_reg in *. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. + destruct (rs ro); try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. - discriminate. @@ -129,8 +153,12 @@ Proof. (* 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). - - exploreInst; apply exec_load_pc_var; auto. - - exploreInst; apply exec_store_pc_var; auto. + - destruct i. + + exploreInst; apply exec_load_offset_pc_var; auto. + + exploreInst; apply exec_load_reg_pc_var; auto. + - destruct i. + + exploreInst; apply exec_store_offset_pc_var; auto. + + exploreInst; apply exec_store_reg_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. @@ -559,16 +587,16 @@ Proof. intros. unfold eval_offset. destruct ofs; auto. erewrite symbol_address_preserved; eauto. Qed. -Lemma transf_exec_load: - forall t rs m rd ra ofs, exec_load ge t rs m rd ra ofs = exec_load tge t rs m rd ra ofs. +Lemma transf_exec_load_offset: + forall t rs m rd ra ofs, exec_load_offset ge t rs m rd ra ofs = exec_load_offset tge t rs m rd ra ofs. Proof. - intros. unfold exec_load. rewrite eval_offset_preserved. reflexivity. + intros. unfold exec_load_offset. rewrite eval_offset_preserved. reflexivity. Qed. -Lemma transf_exec_store: - forall t rs m rs0 ra ofs, exec_store ge t rs m rs0 ra ofs = exec_store tge t rs m rs0 ra ofs. +Lemma transf_exec_store_offset: + forall t rs m rs0 ra ofs, exec_store_offset ge t rs m rs0 ra ofs = exec_store_offset tge t rs m rs0 ra ofs. Proof. - intros. unfold exec_store. rewrite eval_offset_preserved. reflexivity. + intros. unfold exec_store_offset. rewrite eval_offset_preserved. reflexivity. Qed. Lemma transf_exec_basic_instr: @@ -577,8 +605,8 @@ Proof. intros. pose symbol_address_preserved. unfold exec_basic_instr. exploreInst; simpl; auto; try congruence. - unfold exec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. - - apply transf_exec_load. - - apply transf_exec_store. + - apply transf_exec_load_offset. + - apply transf_exec_store_offset. Qed. Lemma transf_exec_body: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 6416b65b..ef02c25a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -164,6 +164,10 @@ module Target (*: TARGET*) = | Ofsimm n -> ptrofs oc n | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) + let addressing oc = function + | AOff ofs -> offset oc ofs + | AReg ro -> ireg oc ro + let icond_name = let open Asmblock in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" @@ -287,27 +291,27 @@ module Target (*: TARGET*) = section oc Section_text (* Load/Store instructions *) - | Plb(rd, ra, ofs) -> - fprintf oc " lbs %a = %a[%a]\n" ireg rd offset ofs ireg ra - | Plbu(rd, ra, ofs) -> - fprintf oc " lbz %a = %a[%a]\n" ireg rd offset ofs ireg ra - | Plh(rd, ra, ofs) -> - fprintf oc " lhs %a = %a[%a]\n" ireg rd offset ofs ireg ra - | Plhu(rd, ra, ofs) -> - fprintf oc " lhz %a = %a[%a]\n" ireg rd offset ofs ireg ra - | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> - fprintf oc " lws %a = %a[%a]\n" ireg rd offset ofs ireg ra - | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " ld %a = %a[%a]\n" ireg rd offset ofs ireg ra + | Plb(rd, ra, adr) -> + fprintf oc " lbs %a = %a[%a]\n" ireg rd addressing adr ireg ra + | Plbu(rd, ra, adr) -> + fprintf oc " lbz %a = %a[%a]\n" ireg rd addressing adr ireg ra + | Plh(rd, ra, adr) -> + fprintf oc " lhs %a = %a[%a]\n" ireg rd addressing adr ireg ra + | Plhu(rd, ra, adr) -> + fprintf oc " lhz %a = %a[%a]\n" 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]\n" 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]\n" ireg rd addressing adr ireg ra - | Psb(rd, ra, ofs) -> - fprintf oc " sb %a[%a] = %a\n" offset ofs ireg ra ireg rd - | Psh(rd, ra, ofs) -> - fprintf oc " sh %a[%a] = %a\n" offset ofs ireg ra ireg rd - | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> - fprintf oc " sw %a[%a] = %a\n" offset ofs ireg ra ireg rd - | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n" offset ofs ireg ra ireg rd + | Psb(rd, ra, adr) -> + fprintf oc " sb %a[%a] = %a\n" addressing adr ireg ra ireg rd + | Psh(rd, ra, adr) -> + fprintf oc " sh %a[%a] = %a\n" addressing adr ireg ra ireg rd + | Psw(rd, ra, adr) | Psw_a(rd, ra, adr) | Pfss(rd, ra, adr) -> + fprintf oc " sw %a[%a] = %a\n" addressing adr ireg ra ireg rd + | Psd(rd, ra, adr) | Psd_a(rd, ra, adr) | Pfsd(rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " sd %a[%a] = %a\n" addressing adr ireg ra ireg rd (* Arith R instructions *) diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 69234938..ed8edfde 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -943,14 +943,16 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - all: try (unfold exec_load in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - all: try (unfold exec_store in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 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. - auto. + 1-10: try (unfold exec_load_offset in H1; destruct (eval_offset ge ofs); try discriminate; unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + 1-10: try (unfold exec_load_reg in H1; destruct (rs1 rofs); try discriminate; unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + 1-10: try (unfold exec_store_offset in H1; destruct (eval_offset ge ofs); try discriminate; unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + 1-10: try (unfold exec_store_reg in H1; destruct (rs1 rofs); try discriminate; unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. + - 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': -- cgit From 6d21e5e9ffc5b3876db3cad987e026206693e416 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 2 Apr 2019 17:40:20 +0200 Subject: legeres simplifications --- mppa_k1c/Machblockgenproof.v | 281 +++++++------------------------------------ 1 file changed, 42 insertions(+), 239 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index f669e6bd..7f877aa3 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -163,114 +163,7 @@ Proof. + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. Qed. - -Definition concat (h: list label) (c: code): code := - match c with - | nil => {| header := h; body := nil; exit := None |}::nil - | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' - end. - -(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? - -Lemma to_bblock_start_label i c l b c0: - (b, c0) = to_bblock (i :: c) - -> In l (header b) - -> i <> Mlabel l - -> exists l2, i=Mlabel l2. -Proof. - unfold to_bblock. - remember (to_bblock_header _) as bh; destruct bh as [h c1]. - remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. - remember (to_bblock_exit _) as be; destruct be as [ext c3]. - intros H; inversion H; subst; clear H; simpl. - destruct i; try (simpl in Heqbh; inversion Heqbh; subst; clear Heqbh; simpl; intuition eauto). -Qed. - -Lemma find_label_stop c: - forall l b c0 c', - (b, c0) = to_bblock c - -> Mach.find_label l c = Some c' - -> In l (header b) - -> exists h, In l h /\ Some (b :: trans_code c0) = Some (concat h (trans_code c')). -Proof. - induction c as [ |i c]. - - simpl; intros; discriminate. - - intros l b c0 c' H H1 H2. - exploit Mach_find_label_split; eauto; clear H1. - intros [(X1 & X2) | (X1 & X2)]. - * subst. exploit to_bblock_label; eauto. clear H. - intros (H3 & H4). constructor 1 with (x:=l::nil); simpl; intuition auto. - symmetry. - rewrite trans_code_equation. - destruct c as [ |i c]. - + unfold to_bblock in H4; simpl in H4. - injection H4. clear H4; intros H4 H H0 H1; subst. simpl. - rewrite trans_code_equation; simpl. - rewrite <- H1 in H3; clear H1. - destruct b as [h b e]; simpl in * |- *; subst; auto. - + rewrite H4; clear H4; simpl. rewrite <- H3; clear H3. - destruct b; simpl; auto. - * exploit to_bblock_start_label; eauto. - intros (l' & H'). subst. - assert (X: l' <> l). { intro Z; subst; destruct X1; auto. } - clear X1. - exploit to_bblock_label; eauto. clear H. - intros (H3 & H4). - exploit IHc; eauto. { simpl. rewrite H3 in H2; simpl in H2. destruct H2; subst; tauto. } - intros (h' & H5 & H6). - constructor 1 with (x:=l'::h'); simpl; intuition auto. - destruct b as [h b e]; simpl in * |- *; subst. - remember (tl h) as th. subst h. - remember (trans_code c') as tcc'. - rewrite trans_code_equation in Heqtcc'. - destruct c'; subst; simpl in * |- *. - + inversion H6; subst; auto. - + destruct (to_bblock (i :: c')) as [b1 c1]. simpl in * |- *. - inversion H6; subst; auto. -Qed. - -Lemma to_bblock_header_find_label c l: forall c1 h c', - to_bblock_header c = (h, c1) - -> Mach.find_label l c = Some c' - -> ~ In l h - -> Mach.find_label l c = Mach.find_label l c1. -Proof. - induction c as [|i c]; simpl; auto. - - intros; discriminate. - - destruct i; - try (simpl; intros c1 h c' H1 H2; inversion H1; subst; clear H1; intros; apply refl_equal). - remember (to_bblock_header c) as tbhc. destruct tbhc as [h2 c2]. - intros h c1 c' H1; inversion H1; subst; clear H1. - simpl. destruct (peq _ _). - + subst; tauto. - + intros H1 H2; erewrite IHc; eauto. -Qed. - -Lemma to_bblock_body_find_label c1 l: forall c2 bdy, - (bdy, c2) = to_bblock_body c1 -> - Mach.find_label l c1 = Mach.find_label l c2. -Proof. - induction c1 as [|i c1]. - - intros bdy0 c0 H. simpl in H. inversion H; subst; clear H. auto. - - intros bdy' c2' H. simpl in H. destruct i; try ( - simpl in H; remember (to_bblock_body c1) as tbb; destruct tbb as [p c'']; - inversion H; subst; clear H; simpl; erewrite IHc1; eauto; fail). -Qed. - -Lemma to_bblock_exit_find_label c1 l c2 ext: - (ext, c2) = to_bblock_exit c1 - -> Mach.find_label l c1 = Mach.find_label l c2. -Proof. - intros H. destruct c1 as [|i c1]. - - simpl in H. inversion H; subst; clear H. auto. - - destruct i; try ( - simpl in H; inversion H; subst; clear H; auto; fail). -Qed. -*) - -Axiom TODO: False. (* A ELIMINER *) - -Lemma find_label_is_end_block_is_label i l c bl: +Lemma find_label_is_end_block_not_label i l c bl: is_end_block (trans_inst i) bl -> is_trans_code c bl -> i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. @@ -290,20 +183,21 @@ Lemma find_label_at_begin l bh bl: In l (header bh) -> find_label l (bh :: bl) = Some (bh::bl). Proof. - intro H; unfold find_label. destruct (is_label l bh) eqn:H0; auto. - rewrite <- is_label_correct_false in H0. tauto. + unfold find_label; rewrite is_label_correct_true; intro H; rewrite H; simpl; auto. Qed. - - Lemma find_label_add_label_diff l bh bl: ~(In l (header bh)) -> - find_label l bl = find_label l (bh::bl). + find_label l (bh::bl) = find_label l bl. Proof. - intros. unfold find_label. destruct (is_label l bh) eqn:H0; auto. - rewrite <- is_label_correct_true in H0. tauto. + unfold find_label; rewrite is_label_correct_false; intro H; rewrite H; simpl; auto. Qed. +Definition concat (h: list label) (c: code): code := + match c with + | nil => {| header := h; body := nil; exit := None |}::nil + | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' + end. Lemma find_label_transcode_preserved: forall l c c', @@ -314,60 +208,48 @@ Proof. rewrite <- is_trans_code_inv in * |-. induction Heqbl. + (* Tr_nil *) - intros. - exists (l::nil). - split. - apply in_eq. - simpl. + intros; exists (l::nil); simpl in * |- *; intuition. discriminate. + (* Tr_end_block *) intros. exploit Mach_find_label_split; eauto. clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. simpl. - unfold add_label, is_label; simpl. - destruct (in_dec l (l::nil)) as [H0|H0]. - * inversion H as [mbi H1 H2| | ]. - subst bl. - inversion Heqbl. - subst c. simpl. eauto. - * destruct H0. simpl; auto. + - subst. rewrite find_label_at_begin; simpl; auto. + inversion H as [mbi H1 H2| | ]. + subst. + inversion Heqbl. + subst. + exists (l :: nil); simpl; eauto. - exploit IHHeqbl; eauto. destruct 1 as (h & H3 & H4). exists h. split; auto. - rewrite (find_label_is_end_block_is_label i l c bl);auto. + erewrite find_label_is_end_block_not_label;eauto. + (* Tr_add_label *) intros. exploit Mach_find_label_split; eauto. clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. simpl. + - subst. inversion H0 as [H1]. clear H0. - unfold add_label, is_label; simpl. + erewrite find_label_at_begin; simpl; eauto. apply is_trans_code_inv in Heqbl. rewrite <- Heqbl. - destruct (in_dec l (l :: header bh)) as [H0|H0]. - * unfold concat. - exists (l :: nil). - split; simpl; eauto. - * destruct H0. simpl; eauto. + exists (l :: nil); simpl; eauto. - subst; assert (H: l0 <> l); try congruence; clear H0. exploit IHHeqbl; eauto. clear IHHeqbl Heqbl. - destruct 1 as (h & H3 & H4). + intros (h & H3 & H4). simpl; unfold is_label, add_label; simpl. destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. * destruct H5; try congruence. exists (l0::h); simpl; intuition. rewrite find_label_at_begin in H4; auto. apply f_equal. inversion H4 as [H5]. clear H4. - unfold concat in * |- *. destruct (trans_code c'); simpl in * |- *; inversion H5; subst; simpl; auto. - * exists h. - split; eauto. - rewrite (find_label_add_label_diff l bh bl); eauto. + * exists h. intuition. + erewrite <- find_label_add_label_diff; eauto. + (* Tr_add_basic *) intros. exploit Mach_find_label_split; eauto. @@ -375,46 +257,11 @@ Proof. rewrite H2 in H. unfold trans_inst in H. congruence. exploit IHHeqbl; eauto. clear IHHeqbl Heqbl. - destruct 1 as (h & H4 & H5). - simpl; unfold is_label. - assert ((header (add_basic bi bh))=(header bh)) as H6. auto. - rewrite H6. - destruct (in_dec l (header bh)) as [H7|H7]; simpl in H6. - * rewrite <- H6 in H7; simpl in H7; destruct H7. - * exists h. - split; eauto. - rewrite (find_label_add_label_diff l bh bl); eauto. + intros (h & H4 & H5). + rewrite find_label_add_label_diff; auto. + rewrite find_label_add_label_diff in H5; eauto. + rewrite H0; auto. Qed. - - -Lemma find_label_add_basic l bh bl: - ~(In l (header bh)) -> - forall bi, find_label l (add_basic bi bh :: bl) = find_label l (bh::bl). -Admitted. - - -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - induction c, (trans_code c) using trans_code_ind. - - intros c' H; inversion H. - - intros c' H. subst _x. destruct c as [| i c]; try tauto. - unfold to_bblock in * |-. - remember (to_bblock_header _) as bh; destruct bh as [h c1]. - remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. - remember (to_bblock_exit _) as be; destruct be as [ext c3]. - simpl; injection e0; intros; subst; clear e0. - unfold is_label; simpl; destruct (in_dec l h) as [Y|Y]. - + clear IHc0. - eapply find_label_stop; eauto. - unfold to_bblock. - rewrite <- Heqbh, <- Heqbb, <- Heqbe. - auto. - + exploit IHc0; eauto. clear IHc0. - rewrite <- H. - erewrite (to_bblock_header_find_label (i::c) l c1); eauto. - erewrite (to_bblock_body_find_label c1 l c2); eauto. - erewrite (to_bblock_exit_find_label c2 l c0); eauto. -Qed. -*) Lemma find_label_preserved: forall l f c, @@ -436,14 +283,12 @@ Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main parent_sp_preserved. - Definition dist_end_block_code (c: Mach.code) := match trans_code c with | nil => 0 | bh::_ => (size bh-1)%nat end. - Definition dist_end_block (s: Mach.state): nat := match s with | Mach.State _ _ _ c _ _ => dist_end_block_code c @@ -453,63 +298,15 @@ Definition dist_end_block (s: Mach.state): nat := Local Hint Resolve exec_nil_body exec_cons_body. Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. -(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? - -Ltac ExploitDistEndBlockCode := - match goal with - | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => - exploit (to_bblock_size_single_label c (Mlabel l)); eauto - | [ H : dist_end_block_code (?i0 :: ?c) <> 0%nat |- _ ] => - exploit (to_bblock_size_single_basic c i0); eauto - | _ => idtac - end. - -Ltac totologize H := - match type of H with - | ( ?id = _ ) => - let Hassert := fresh "Htoto" in ( - assert (id = id) as Hassert; auto; rewrite H in Hassert at 2; simpl in Hassert; rewrite H in Hassert) - end. +Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. +Proof. + unfold add_label, size; simpl; omega. +Qed. -Lemma dist_end_block_code_simu_mid_block i c: - dist_end_block_code (i::c) <> 0 -> - (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). +Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. Proof. - intros H. - unfold dist_end_block_code. - destruct (get_code_nature (i::c)) eqn:GCNIC. - - apply get_code_nature_empty in GCNIC. discriminate. - - rewrite to_bblock_size_single_label; auto. - destruct c as [|i' c]. - + contradict H. destruct i; simpl; auto. - + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. omega. - - destruct (get_code_nature c) eqn:GCNC. - + apply get_code_nature_empty in GCNC. subst. contradict H. destruct i; simpl; auto. - + contradict H. destruct c as [|i' c]; try discriminate. - destruct i'; try discriminate. - destruct i; try discriminate. all: simpl; auto. - + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. - erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. - simpl. destruct c as [|i' c]; try discriminate. - assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. - cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). - unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. - rewrite to_bblock_noLabel. simpl; auto. - rewrite GCNC. discriminate. - omega. - + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. - erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. - simpl. destruct c as [|i' c]; try discriminate. - assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. - cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). - unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. - rewrite to_bblock_noLabel. simpl; auto. - rewrite GCNC. discriminate. - omega. - - contradict H. destruct i; try discriminate. - all: unfold dist_end_block_code; erewrite to_bblock_CFI; eauto; simpl; eauto. + destruct i; auto. Qed. -*) Lemma dist_end_block_code_simu_mid_block i c: dist_end_block_code (i::c) <> 0 -> @@ -517,9 +314,15 @@ Lemma dist_end_block_code_simu_mid_block i c: Proof. unfold dist_end_block_code. remember (trans_code (i::c)) as bl. - rewrite <- is_trans_code_inv in * |-. - inversion Heqbl as [| | |]; subst. -Admitted. (* A FAIRE *) + rewrite <- is_trans_code_inv in Heqbl. + inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; + rewrite is_trans_code_inv in H; rewrite <- H. + omega. +Admitted. (* A FINIR *) + +Axiom TODO: False. (* a éliminer *) Local Hint Resolve dist_end_block_code_simu_mid_block. -- cgit From 61289bf034eebcfcaf04e833876d583e47aef659 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Apr 2019 10:34:34 +0200 Subject: Small refactoring and renaming of Stores and Loads --- mppa_k1c/Asmblock.v | 20 ++++++------- mppa_k1c/Asmblockdeps.v | 24 ++++++++-------- mppa_k1c/Asmblockgen.v | 76 ++++++++++++++++++------------------------------- 3 files changed, 50 insertions(+), 70 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3656b91f..9d7b372e 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -244,7 +244,7 @@ Inductive cf_instruction : Type := . (** Loads **) -Inductive load_name_rro : Type := +Inductive load_name : Type := | Plb (**r load byte *) | Plbu (**r load byte unsigned *) | Plh (**r load half word *) @@ -258,15 +258,15 @@ Inductive load_name_rro : Type := . Inductive ld_instruction : Type := - | PLoadRRO (i: load_name_rro) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (i: load_name_rro) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) . -Coercion PLoadRRO: load_name_rro >-> Funclass. -Coercion PLoadRRR: load_name_rro >-> Funclass. +Coercion PLoadRRO: load_name >-> Funclass. +Coercion PLoadRRR: load_name >-> Funclass. (** Stores **) -Inductive store_name_rro : Type := +Inductive store_name : Type := | Psb (**r store byte *) | Psh (**r store half byte *) | Psw (**r store int32 *) @@ -278,12 +278,12 @@ Inductive store_name_rro : Type := . Inductive st_instruction : Type := - | PStoreRRO (i: store_name_rro) (rs: ireg) (ra: ireg) (ofs: offset) - | PStoreRRR (i: store_name_rro) (rs: ireg) (ra: ireg) (rofs: ireg) + | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) + | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) . -Coercion PStoreRRO: store_name_rro >-> Funclass. -Coercion PStoreRRR: store_name_rro >-> Funclass. +Coercion PStoreRRO: store_name >-> Funclass. +Coercion PStoreRRR: store_name >-> Funclass. (** Arithmetic instructions **) Inductive arith_name_r : Type := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 7e332895..e038a5ae 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -71,18 +71,18 @@ Coercion OArithRRI32: arith_name_rri32 >-> Funclass. Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := - | OLoadRRO (n: load_name_rro) (ofs: offset) - | OLoadRRR (n: load_name_rro) + | OLoadRRO (n: load_name) (ofs: offset) + | OLoadRRR (n: load_name) . -Coercion OLoadRRO: load_name_rro >-> Funclass. +Coercion OLoadRRO: load_name >-> Funclass. Inductive store_op := - | OStoreRRO (n: store_name_rro) (ofs: offset) - | OStoreRRR (n: store_name_rro) + | OStoreRRO (n: store_name) (ofs: offset) + | OStoreRRR (n: store_name) . -Coercion OStoreRRO: store_name_rro >-> Funclass. +Coercion OStoreRRO: store_name >-> Funclass. Inductive op_wrap := | Arith (ao: arith_op) @@ -1571,7 +1571,7 @@ Definition string_of_arith (op: arith_op): pstring := | OArithARRI64 n _ => string_of_name_arri64 n end. -Definition string_of_name_lrro (n: load_name_rro) : pstring := +Definition string_of_load_name (n: load_name) : pstring := match n with Plb => "Plb" | Plbu => "Plbu" @@ -1587,11 +1587,11 @@ Definition string_of_name_lrro (n: load_name_rro) : pstring := Definition string_of_load (op: load_op): pstring := match op with - | OLoadRRO n _ => string_of_name_lrro n - | OLoadRRR n => string_of_name_lrro n + | OLoadRRO n _ => string_of_load_name n + | OLoadRRR n => string_of_load_name n end. -Definition string_of_name_srro (n: store_name_rro) : pstring := +Definition string_of_store_name (n: store_name) : pstring := match n with Psb => "Psb" | Psh => "Psh" @@ -1605,8 +1605,8 @@ Definition string_of_name_srro (n: store_name_rro) : pstring := Definition string_of_store (op: store_op) : pstring := match op with - | OStoreRRO n _ => string_of_name_srro n - | OStoreRRR n => string_of_name_srro n + | OStoreRRO n _ => string_of_store_name n + | OStoreRRR n => string_of_store_name n end. Definition string_of_control (op: control_op) : pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 1afb627a..f207b64d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -792,61 +792,41 @@ Definition transl_memory_access Error(msg "Asmblockgen.transl_memory_access") end. +Definition chunk2load (chunk: memory_chunk) := + match chunk with + | Mint8signed => Plb + | Mint8unsigned => Plbu + | Mint16signed => Plh + | Mint16unsigned => Plhu + | Mint32 => Plw + | Mint64 => Pld + | Mfloat32 => Pfls + | Mfloat64 => Pfld + | Many32 => Plw_a + | Many64 => Pld_a + end. + Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + do r <- ireg_of dst; + transl_memory_access (chunk2load chunk r) addr args k. + +Definition chunk2store (chunk: memory_chunk) := match chunk with - | Mint8signed => - do r <- ireg_of dst; - transl_memory_access (Plb r) addr args k - | Mint8unsigned => - do r <- ireg_of dst; - transl_memory_access (Plbu r) addr args k - | Mint16signed => - do r <- ireg_of dst; - transl_memory_access (Plh r) addr args k - | Mint16unsigned => - do r <- ireg_of dst; - transl_memory_access (Plhu r) addr args k - | Mint32 => - do r <- ireg_of dst; - transl_memory_access (Plw r) addr args k - | Mint64 => - do r <- ireg_of dst; - transl_memory_access (Pld r) addr args k - | Mfloat32 => - do r <- freg_of dst; - transl_memory_access (Pfls r) addr args k - | Mfloat64 => - do r <- freg_of dst; - transl_memory_access (Pfld r) addr args k - | _ => - Error (msg "Asmblockgen.transl_load") + | Mint8signed | Mint8unsigned => Psb + | Mint16signed | Mint16unsigned => Psh + | Mint32 => Psw + | Mint64 => Psd + | Mfloat32 => Pfss + | Mfloat64 => Pfsd + | Many32 => Psw_a + | Many64 => Psd_a end. Definition transl_store (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) (k: bcode) : res bcode := - match chunk with - | Mint8signed | Mint8unsigned => - do r <- ireg_of src; - transl_memory_access (Psb r) addr args k - | Mint16signed | Mint16unsigned => - do r <- ireg_of src; - transl_memory_access (Psh r) addr args k - | Mint32 => - do r <- ireg_of src; - transl_memory_access (Psw r) addr args k - | Mint64 => - do r <- ireg_of src; - transl_memory_access (Psd r) addr args k - | Mfloat32 => - do r <- freg_of src; - transl_memory_access (Pfss r) addr args k - | Mfloat64 => - do r <- freg_of src; - transl_memory_access (Pfsd r) addr args k - | _ => - Error (msg "Asmblockgen.transl_store") - end. + do r <- ireg_of src; + transl_memory_access (chunk2store chunk r) addr args k. (** Function epilogue *) -- cgit From f2426972df3fa959f09490b0b5752906d949c978 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Apr 2019 11:00:46 +0200 Subject: We now generate load/store with 3 registers (ld rd rs1[rs2]), proofs admitted --- mppa_k1c/Asmblockgen.v | 49 ++++- mppa_k1c/Asmblockgenproof.v | 456 +------------------------------------------ mppa_k1c/Asmblockgenproof1.v | 40 +--- 3 files changed, 51 insertions(+), 494 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f207b64d..54a1b0f4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -741,11 +741,7 @@ Definition indexed_memory_access match make_immed64 (Ptrofs.to_int64 ofs) with | Imm64_single imm => mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) -(*| Imm64_pair hi lo => - Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k - | Imm64_large imm => - Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k -*)end. +end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := match ty, preg_of dst with @@ -777,6 +773,17 @@ Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := (** Translation of memory accesses: loads, and stores. *) +Definition transl_memory_access2 + (mk_instr: ireg -> ireg -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := + match addr, args with + | Aindexed2, a1 :: a2 :: nil => + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (mk_instr rs1 rs2 ::i k) + | _, _ => Error (msg "Asmblockgen.transl_memory_access2") + end. + Definition transl_memory_access (mk_instr: ireg -> offset -> basic) (addr: addressing) (args: list mreg) (k: bcode) : res bcode := @@ -806,10 +813,22 @@ Definition chunk2load (chunk: memory_chunk) := | Many64 => Pld_a end. -Definition transl_load (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rro (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access (chunk2load chunk r) addr args k. + transl_memory_access (PLoadRRO (chunk2load chunk) r) addr args k. + +Definition transl_load_rrr (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. + +Definition transl_load (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + match args with + | a1 :: a2 :: nil => transl_load_rrr chunk addr args dst k + | _ => transl_load_rro chunk addr args dst k + end. Definition chunk2store (chunk: memory_chunk) := match chunk with @@ -823,10 +842,22 @@ Definition chunk2store (chunk: memory_chunk) := | Many64 => Psd_a end. -Definition transl_store (chunk: memory_chunk) (addr: addressing) +Definition transl_store_rro (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + do r <- ireg_of src; + transl_memory_access (PStoreRRO (chunk2store chunk) r) addr args k. + +Definition transl_store_rrr (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) (k: bcode) : res bcode := do r <- ireg_of src; - transl_memory_access (chunk2store chunk r) addr args k. + transl_memory_access2 (PStoreRRR (chunk2store chunk) r) addr args k. + +Definition transl_store (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + match args with + | a1 :: a2 :: nil => transl_store_rrr chunk addr args src k + | _ => transl_load_rro chunk addr args src k + end. (** Function epilogue *) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 63f4c136..81474d30 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -16,7 +16,6 @@ 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 Asmgen Asmgenproof0 Asmgenproof1. *) Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. Module MB := Machblock. @@ -75,34 +74,6 @@ Proof. omega. Qed. -(* -Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inv H. - eapply exec_straight_steps_1; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c ep tf tc c' ep' tc' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - transl_code f c' ep' = OK tc' -> - exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. -Proof. - intros. inv H. - exploit exec_straight_steps_2; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - *) (** The following lemmas show that the translation from Mach to Asm preserves labels, in the sense that the following diagram commutes: << @@ -121,314 +92,6 @@ Qed. Section TRANSL_LABEL. -(* Remark loadimm32_label: - forall r n k, tail_nolabel k (loadimm32 r n k). -Proof. - intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm32_label: labels. - -Remark opimm32_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm32 op opimm r1 r2 n k). -Proof. - intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel. -(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm32_label: labels. - -Remark loadimm64_label: - forall r n k, tail_nolabel k (loadimm64 r n k). -Proof. - intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve loadimm64_label: labels. - -Remark cast32signed_label: - forall rd rs k, tail_nolabel k (cast32signed rd rs k). -Proof. - intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel. -Qed. -Hint Resolve cast32signed_label: labels. - -Remark opimm64_label: - forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k, - (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> - (forall r1 r2 n, nolabel (opimm r1 r2 n)) -> - tail_nolabel k (opimm64 op opimm r1 r2 n k). -Proof. - intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel. -(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*) -Qed. -Hint Resolve opimm64_label: labels. - -Remark addptrofs_label: - forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k). -Proof. - unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel. - apply opimm64_label; TailNoLabel. -Qed. -Hint Resolve addptrofs_label: labels. -(* -Remark transl_cond_float_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_float; intros. destruct c; inv H; exact I. -Qed. - -Remark transl_cond_single_nolabel: - forall c r1 r2 r3 insn normal, - transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. -Proof. - unfold transl_cond_single; intros. destruct c; inv H; exact I. -Qed. -*) -Remark transl_cbranch_label: - forall cond args lbl k c, - transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cbranch in H. destruct cond; TailNoLabel. -(* Ccomp *) - - unfold transl_comp; TailNoLabel. -(* Ccompu *) - - unfold transl_comp; TailNoLabel. -(* Ccompimm *) - - destruct (Int.eq n Int.zero); TailNoLabel. - unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel. -(* Ccompuimm *) - - unfold transl_opt_compuimm. - remember (select_comp n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp; - destruct (Int.eq n Int.zero); destruct c0; discriminate. - + unfold loadimm32; - destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel. -(* Ccompl *) - - unfold transl_compl; TailNoLabel. -(* Ccomplu *) - - unfold transl_compl; TailNoLabel. -(* Ccomplimm *) - - destruct (Int64.eq n Int64.zero); TailNoLabel. - unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel. -(* Ccompluimm *) - - unfold transl_opt_compluimm. - remember (select_compl n c0) as selcomp; destruct selcomp. - + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl; - destruct (Int64.eq n Int64.zero); destruct c0; discriminate. - + unfold loadimm64; - destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel. -Qed. - -(* -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int.eq n Int.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (Int64.eq n Int64.zero). - destruct c0; simpl; TailNoLabel. - apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). - auto with labels. destruct c0; simpl; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. - apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. -*) - -Remark transl_cond_op_label: - forall cond args r k c, - transl_cond_op cond r args k = OK c -> tail_nolabel k c. -Proof. - intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. -- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel. -- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel. -Qed. - -Remark transl_op_label: - forall op args r k c, - transl_op op args r k = OK c -> tail_nolabel k c. -Proof. -Opaque Int.eq. - unfold transl_op; intros; destruct op; TailNoLabel. -(* Omove *) -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -(* Oaddrsymbol *) -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel. -(* Oaddimm32 *) -- apply opimm32_label; intros; exact I. -(* Oandimm32 *) -- apply opimm32_label; intros; exact I. -(* Oorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oxorimm32 *) -- apply opimm32_label; intros; exact I. -(* Oshrximm *) -- destruct (Int.eq n Int.zero); TailNoLabel. -(* Oaddimm64 *) -- apply opimm64_label; intros; exact I. -(* Oandimm64 *) -- apply opimm64_label; intros; exact I. -(* Oorimm64 *) -- apply opimm64_label; intros; exact I. -(* Oxorimm64 *) -- apply opimm64_label; intros; exact I. -(* Ocmp *) -- eapply transl_cond_op_label; eauto. -Qed. - -(* -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -- destruct (Float.eq_dec n Float.zero); TailNoLabel. -- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. -- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. -+ TailNoLabel. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- apply opimm32_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- apply opimm64_label; intros; exact I. -- destruct (Int.eq n Int.zero); TailNoLabel. -- eapply transl_cond_op_label; eauto. -*) -*) - -(* Remark indexed_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) base ofs k, - (forall r o, nolabel (mk_instr r o)) -> - tail_nolabel k (indexed_memory_access mk_instr base ofs k). -Proof. - unfold indexed_memory_access; intros. - (* destruct Archi.ptr64. *) - destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel. - (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *) -Qed. *) - -(* -Remark loadind_label: - forall base ofs ty dst k c, - loadind base ofs ty dst k = OK c -> tail_nolabel k c. -Proof. - unfold loadind; intros. - destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark storeind_label: - forall src base ofs ty k c, - storeind src base ofs ty k = OK c -> tail_nolabel k c. -Proof. - unfold storeind; intros. - destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. -Qed. - -Remark loadind_ptr_label: - forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. -*) - -(* Remark storeind_ptr_label: - forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k). -Proof. - intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I. -Qed. *) - -(* -Remark transl_memory_access_label: - forall (mk_instr: ireg -> offset -> instruction) addr args k c, - (forall r o, nolabel (mk_instr r o)) -> - transl_memory_access mk_instr addr args k = OK c -> - tail_nolabel k c. -Proof. - unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. -Qed. - -Remark make_epilogue_label: - forall f k, tail_nolabel k (make_epilogue f k). -Proof. - unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel. -Qed. - -Lemma transl_instr_label: - forall f i ep k c, - transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end. -Proof. - unfold transl_instr; intros; destruct i; TailNoLabel. -(* loadind *) -- eapply loadind_label; eauto. -(* storeind *) -- eapply storeind_label; eauto. -(* Mgetparam *) -- destruct ep. eapply loadind_label; eauto. - eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. -(* transl_op *) -- eapply transl_op_label; eauto. -(* transl_load *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -(* transl store *) -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; TailNoLabel. -- destruct s0; monadInv H; eapply tail_nolabel_trans - ; [eapply make_epilogue_label|TailNoLabel]. -- eapply transl_cbranch_label; eauto. -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -Qed. -(* - - -- eapply transl_op_label; eauto. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I. -- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. -*) - -Lemma transl_instr_label': - forall lbl f i ep k c, - transl_instr f i ep k = OK c -> - find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply B). - intros. subst c. simpl. auto. -Qed. -*) - Lemma gen_bblocks_label: forall hd bdy ex tbb tc, gen_bblocks hd bdy ex = tbb::tc -> @@ -640,115 +303,6 @@ Qed. - Mach register values and Asm register values agree. *) -(* -Lemma exec_straight_steps: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists rs2, - exec_straight tge tf c rs1 m1' k rs2 m2' - /\ agree ms2 sp rs2 - /\ (fp_is_parent ep i = true -> rs2#FP = parent_sp s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c ms2 m2) st'. -Proof. - intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B C]]]. - exists (State rs2 m2'); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. -*) - -(* -Lemma exec_straight_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - fp_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. - -Lemma exec_straight_opt_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - fp_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - inv A. -- exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -- exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. *) - (** We need to show that, in the simulation diagram, we cannot take infinitely many Mach transitions that correspond to zero transitions on the Asm side. Actually, all Mach transitions @@ -967,9 +521,9 @@ Proof. 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: unfold transl_memory_access in EQ0; exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; exploreInst; try discriminate. - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: unfold transl_memory_access in EQ0; exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; exploreInst; try discriminate. Qed. Lemma transl_basic_code_nonil: @@ -1631,7 +1185,7 @@ Local Transparent destroyed_by_op. 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. + exploit transl_load_correct; eauto. admit. intros [rs2 [P [Q R]]]. eapply exec_straight_body in P. @@ -1658,7 +1212,7 @@ Local Transparent destroyed_by_op. 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]]. + exploit transl_store_correct; eauto. admit. intros [rs2 [P Q]]. eapply exec_straight_body in P. 2: eapply code_to_basics_id; eauto. @@ -1673,7 +1227,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Qed. +Admitted. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index f8bbf7f4..06c9fb3e 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -30,40 +30,13 @@ Lemma make_immed32_sound: Proof. intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). predSpec Int.eq Int.eq_spec n lo; auto. -(* -- auto. -- set (m := Int.sub n lo). - assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). - assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). - { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. - auto using Int.eqmod_sub, Int.eqmod_refl. } - assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). - { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. - apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. - exists (two_p (32-12)); auto. } - assert (D: Int.modu m (Int.repr 4096) = Int.zero). - { apply Int.eqmod_mod_eq in C. unfold Int.modu. - change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. - reflexivity. - apply two_p_gt_ZERO; omega. } - rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. - rewrite Int.shl_mul_two_p. - change (two_p (Int.unsigned (Int.repr 12))) with 4096. - replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. - unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). - rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. - rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). - rewrite D. apply Int.add_zero. -*) Qed. Lemma make_immed64_sound: forall n, match make_immed64 n with | Imm64_single imm => n = imm -(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo - | Imm64_large imm => n = imm -*)end. + end. Proof. intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). predSpec Int64.eq Int64.eq_spec n lo. @@ -76,7 +49,6 @@ Proof. Qed. - (** Properties of registers *) Lemma ireg_of_not_RTMP: @@ -2000,10 +1972,10 @@ Proof. /\ 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 ge chunk rs m rd base ofs). - { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (esplit; eauto). } + { (* unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (esplit; eauto). *) admit. } destruct A as (mk_instr & rd & rdEq & B & C). rewrite rdEq. eapply transl_load_access_correct; eauto with asmgen. -Qed. +Admitted. Lemma transl_store_correct: forall chunk addr args src k c (rs: regset) m a m', @@ -2021,16 +1993,16 @@ Proof. /\ (forall base ofs rs, exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk' rs m rr base ofs) /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). - { unfold transl_store in TR; destruct chunk; ArgsInv; + { admit. (* unfold transl_store in TR; destruct chunk; ArgsInv; (econstructor; econstructor; econstructor; split; [eauto | split; [eassumption | split; [ intros; simpl; reflexivity | auto]]]). destruct a; auto. apply Mem.store_signed_unsigned_8. - destruct a; auto. apply Mem.store_signed_unsigned_16. + destruct a; auto. apply Mem.store_signed_unsigned_16. *) } destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D). rewrite D in STORE; clear D. eapply transl_store_access_correct; eauto with asmgen. congruence. destruct rr; try discriminate. destruct src; try discriminate. -Qed. +Admitted. Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, -- cgit From 34261e53d0da905307eb3e0a0b711571365b078e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Apr 2019 12:04:33 +0200 Subject: Preuve du transl_load et transl_store registre offset --- mppa_k1c/Asmblockgen.v | 10 ++-- mppa_k1c/Asmblockgenproof1.v | 109 +++++++++++++++++++++++++++++++++---------- 2 files changed, 89 insertions(+), 30 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 54a1b0f4..3260312d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -825,8 +825,8 @@ Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match args with - | a1 :: a2 :: nil => transl_load_rrr chunk addr args dst k + match addr with + | Aindexed2 => transl_load_rrr chunk addr args dst k | _ => transl_load_rro chunk addr args dst k end. @@ -854,9 +854,9 @@ Definition transl_store_rrr (chunk: memory_chunk) (addr: addressing) Definition transl_store (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) (k: bcode) : res bcode := - match args with - | a1 :: a2 :: nil => transl_store_rrr chunk addr args src k - | _ => transl_load_rro chunk addr args src k + match addr with + | Aindexed2 => transl_store_rrr chunk addr args src k + | _ => transl_store_rro chunk addr args src k end. (** Function epilogue *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 06c9fb3e..220f631e 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1956,6 +1956,29 @@ Proof. auto. Qed. +Lemma transl_load_memory_access_ok: + forall addr chunk args dst k c rs a v m, + addr <> Aindexed2 -> + transl_load 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 ge 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_correct: forall chunk addr args dst k c (rs: regset) m a v, transl_load chunk addr args dst k = OK c -> @@ -1966,17 +1989,62 @@ Lemma transl_load_correct: /\ rs'#(preg_of dst) = v /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. - intros until v; intros TR EV LOAD. - assert (A: 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 ge chunk rs m rd base ofs). - { (* unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (esplit; eauto). *) admit. } - destruct A as (mk_instr & rd & rdEq & B & C). rewrite rdEq. - eapply transl_load_access_correct; eauto with asmgen. + intros until v; intros TR EV LOAD. destruct addr. + 2-4: exploit transl_load_memory_access_ok; eauto; try discriminate; + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + admit. Admitted. +Remark exec_store_offset_8_sign rs m x base ofs: + exec_store_offset ge Mint8unsigned rs m x base ofs = exec_store_offset ge Mint8signed rs m x base ofs. +Proof. + unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold exec_store. unfold Mem.storev. + destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_offset_16_sign rs m x base ofs: + exec_store_offset ge Mint16unsigned rs m x base ofs = exec_store_offset ge Mint16signed rs m x base ofs. +Proof. + unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold exec_store. unfold Mem.storev. + destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + +Lemma transl_store_memory_access_ok: + forall addr chunk args src k c rs a m m', + addr <> Aindexed2 -> + transl_store chunk addr args src k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr, + preg_of src = IR rr + /\ 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_store_offset ge chunk' rs m rr base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros ? TR ? ?. + unfold transl_store in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; [ + repeat (destruct args; try discriminate); eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; + [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; + [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. +Qed. + Lemma transl_store_correct: forall chunk addr args src k c (rs: regset) m a m', transl_store chunk addr args src k = OK c -> @@ -1986,22 +2054,13 @@ Lemma transl_store_correct: exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. - intros until m'; intros TR EV STORE. - assert (A: exists mk_instr chunk' rr, - preg_of src = IR rr - /\ 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_store_offset ge chunk' rs m rr base ofs) - /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). - { admit. (* unfold transl_store in TR; destruct chunk; ArgsInv; - (econstructor; econstructor; econstructor; split; [eauto | split; [eassumption | split; [ intros; simpl; reflexivity | auto]]]). - destruct a; auto. apply Mem.store_signed_unsigned_8. - destruct a; auto. apply Mem.store_signed_unsigned_16. *) - } - destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D). - rewrite D in STORE; clear D. - eapply transl_store_access_correct; eauto with asmgen. congruence. - destruct rr; try discriminate. destruct src; try discriminate. + intros until m'; intros TR EV STORE. destruct addr. + 2-4: exploit transl_store_memory_access_ok; eauto; try discriminate; intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. + admit. Admitted. Lemma make_epilogue_correct: -- cgit From 52836c3aa914f864d464031a2f0948afb07e84e3 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 3 Apr 2019 13:53:32 +0200 Subject: introduce a small tactic. --- mppa_k1c/Machblockgenproof.v | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 7f877aa3..eb330e99 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -199,6 +199,10 @@ Definition concat (h: list label) (c: code): code := | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' end. +Ltac subst_is_trans_code H := + rewrite is_trans_code_inv in H; + rewrite <- H in * |- *. + Lemma find_label_transcode_preserved: forall l c c', Mach.find_label l c = Some c' -> @@ -233,8 +237,7 @@ Proof. inversion H0 as [H1]. clear H0. erewrite find_label_at_begin; simpl; eauto. - apply is_trans_code_inv in Heqbl. - rewrite <- Heqbl. + subst_is_trans_code Heqbl. exists (l :: nil); simpl; eauto. - subst; assert (H: l0 <> l); try congruence; clear H0. exploit IHHeqbl; eauto. @@ -254,7 +257,7 @@ Proof. intros. exploit Mach_find_label_split; eauto. destruct 1 as [(H2&H3)|(H2&H3)]. - rewrite H2 in H. unfold trans_inst in H. congruence. + rewrite H2 in H. unfold trans_inst in H. congruence. exploit IHHeqbl; eauto. clear IHHeqbl Heqbl. intros (h & H4 & H5). @@ -318,7 +321,7 @@ Proof. inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. - rewrite size_add_to_newblock; omega. - rewrite size_add_label; - rewrite is_trans_code_inv in H; rewrite <- H. + subst_is_trans_code H. omega. Admitted. (* A FINIR *) -- cgit From e0fb40f126c980819869bf2a2f32f7332b1b4a5a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Apr 2019 16:32:59 +0200 Subject: Preuve des load/store registre registre. Reste des modifs mineures dans les preuves de Asmblockdeps --- mppa_k1c/Asmblock.v | 38 +++----- mppa_k1c/Asmblockdeps.v | 26 +++--- mppa_k1c/Asmblockgenproof.v | 6 +- mppa_k1c/Asmblockgenproof1.v | 186 +++++++++++++++++++++++++++++++------ mppa_k1c/PostpassSchedulingproof.v | 9 +- mppa_k1c/lib/Asmblockgenproof0.v | 8 +- 6 files changed, 196 insertions(+), 77 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9d7b372e..408b8c31 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1262,44 +1262,34 @@ Definition eval_offset (ofs: offset) : res ptrofs := end end. -Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) - (d: ireg) (a: ireg) (ptr: ptrofs) := - match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with - | None => Stuck - | Some v => Next (rs#d <- v) m - end -. - Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := match (eval_offset ofs) with - | OK ptr => exec_load chunk rs m d a ptr + | OK ptr => match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with + | None => Stuck + | Some v => Next (rs#d <- v) m + end | _ => Stuck end. Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := - match (rs ro) with - | Vptr _ ofs => exec_load chunk rs m d a ofs - | _ => Stuck - end. - -Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) - (s: ireg) (a: ireg) (ptr: ptrofs) := - match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with + match Mem.loadv chunk m (Val.addl (rs a) (rs ro)) with | None => Stuck - | Some m' => Next rs m' - end -. + | Some v => Next (rs#d <- v) m + end. Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := match (eval_offset ofs) with - | OK ptr => exec_store chunk rs m s a ptr + | OK ptr => match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with + | None => Stuck + | Some m' => Next rs m' + end | _ => Stuck end. Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := - match (rs ro) with - | Vptr _ ofs => exec_store chunk rs m s a ofs - | _ => Stuck + match Mem.storev chunk m (Val.addl (rs a) (rs ro)) (rs s) with + | None => Stuck + | Some m' => Next rs m' end. Definition load_chunk n := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e038a5ae..ac8fa6bd 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -831,7 +831,8 @@ Proof. - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. (* Load *) - - simpl in H. destruct i. + - simpl in H. admit. + (* destruct i. (* Load Offset *) + destruct i. all: unfold exec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_load in H; @@ -848,10 +849,11 @@ Proof. simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold exec_load_deps_reg; rewrite ROFS; unfold exec_load_deps; simpl in MEML; rewrite MEML; reflexivity | Simpl - | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. *) (* Store *) - - simpl in H. destruct i. + - simpl in H. admit. + (* destruct i. (* Store Offset *) + destruct i. all: unfold exec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_store in H; @@ -869,7 +871,7 @@ Proof. unfold exec_store_deps; simpl in MEML; rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl ]. - + *) (* Allocframe *) - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. inv H. inv H0. eexists. split; try split. @@ -895,7 +897,7 @@ Proof. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. (* Pnop *) - simpl in H. inv H. inv H0. eexists. split; try split. assumption. assumption. -Qed. +Admitted. Lemma forward_simu_body: forall bdy ge rs m rs' m' fn s, @@ -1211,23 +1213,23 @@ Proof. (* Load Offset *) + destruct i. all: simpl; rewrite H2; rewrite (H3 ra); unfold exec_load_offset in H0; destruct (eval_offset _ _); auto; - unfold exec_load in H0; unfold exec_load_deps; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. + unfold exec_load_deps; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. (* Load Reg *) - + destruct i. all: + + admit. (* destruct i. all: simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); unfold exec_load_reg in H0; unfold exec_load_deps_reg; - destruct (rs rofs); auto; unfold exec_load in H0; simpl in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + destruct (rs rofs); auto; unfold exec_load in H0; simpl in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. *) (* PStore *) - destruct i. (* Store Offset *) + destruct i. all: simpl; rewrite H2; rewrite (H3 ra); rewrite (H3 rs0); unfold exec_store_offset in H0; destruct (eval_offset _ _); auto; - unfold exec_store in H0; simpl in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _); auto; discriminate. + simpl in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _); auto; discriminate. (* Store Reg *) - + destruct i. all: + + admit. (* destruct i. all: simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); rewrite (H3 rs0); simpl in H0; unfold exec_store_reg in H0; unfold exec_store_deps_reg; destruct (rs rofs); auto; unfold exec_store in H0; unfold exec_store_deps; - destruct (Mem.storev _ _ _ _); auto; discriminate. + destruct (Mem.storev _ _ _ _); auto; discriminate. *) (* Pallocframe *) - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. destruct (Mem.alloc _ _ _). simpl in H0. @@ -1241,7 +1243,7 @@ Proof. all: simpl; auto. - simpl. destruct rd; subst; try discriminate. all: simpl; auto. -Qed. +Admitted. Lemma forward_simu_body_stuck: forall bdy ge fn rs m s, diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 81474d30..70f188ec 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1185,7 +1185,7 @@ Local Transparent destroyed_by_op. 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. admit. + exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. eapply exec_straight_body in P. @@ -1212,7 +1212,7 @@ Local Transparent destroyed_by_op. 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. admit. intros [rs2 [P Q]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. eapply exec_straight_body in P. 2: eapply code_to_basics_id; eauto. @@ -1227,7 +1227,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Admitted. +Qed. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 220f631e..5ccea246 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1749,7 +1749,7 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load_offset. rewrite PtrEq. unfold exec_load. rewrite B, LOAD. eauto. Simpl. + unfold exec_load_offset. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. split; intros; Simpl. auto. Qed. @@ -1769,7 +1769,7 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store_offset. rewrite PtrEq. unfold exec_store. rewrite B, C, STORE. + unfold exec_store_offset. rewrite PtrEq. rewrite B, C, STORE. eauto. discriminate. { intro. inv H. contradiction. } @@ -1913,11 +1913,29 @@ Proof. inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. Qed. -Lemma transl_load_access_correct: - forall 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 ge chunk rs m rd base ofs) -> - transl_memory_access mk_instr addr args k = OK c -> +Lemma transl_memory_access2_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ro mro mr1 rs', + args = mr1 :: mro :: nil + /\ ireg_of mro = OK ro + /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m + /\ Val.addl rs'#base rs'#ro = v + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access2 in TR; destruct addr; ArgsInv. + inv EV. repeat eexists. eassumption. econstructor; eauto. +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', + 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) -> + 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' -> exists rs', @@ -1925,35 +1943,34 @@ Lemma transl_load_access_correct: /\ rs'#rd = v' /\ 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). + intros until v'; 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. - rewrite INSTR. unfold exec_load_offset. unfold exec_load. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. rewrite B, LOAD. reflexivity. Simpl. split; intros; Simpl. auto. Qed. -Lemma transl_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', +Lemma transl_load_access_correct: + forall 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_store_offset ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset ge 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.storev chunk m v rs#r1 = Some m' -> - r1 <> RTMP -> + Mem.loadv chunk m v = Some v' -> exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. Proof. - intros until m'; intros INSTR TR EV STORE NOT31. + 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_store_offset. unfold exec_store. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. - intro. inv H. contradiction. - auto. + rewrite INSTR. unfold exec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. Qed. Lemma transl_load_memory_access_ok: @@ -1979,6 +1996,28 @@ Proof. | 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 -> + 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 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 + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg 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 + | 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 -> @@ -1993,20 +2032,68 @@ Proof. 2-4: exploit transl_load_memory_access_ok; eauto; try discriminate; intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; eapply transl_load_access_correct; eauto with asmgen. - admit. -Admitted. + - exploit transl_load_memory_access2_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. +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 -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. 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_store_reg. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOT31. + 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_store_offset. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + Remark exec_store_offset_8_sign rs m x base ofs: exec_store_offset ge Mint8unsigned rs m x base ofs = exec_store_offset ge Mint8signed rs m x base ofs. Proof. - unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold exec_store. unfold Mem.storev. + unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. Qed. Remark exec_store_offset_16_sign rs m x base ofs: exec_store_offset ge Mint16unsigned rs m x base ofs = exec_store_offset ge Mint16signed rs m x base ofs. Proof. - unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold exec_store. unfold Mem.storev. + unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. Qed. @@ -2045,6 +2132,45 @@ Proof. eapply exec_store_offset_16_sign. Qed. +Remark exec_store_reg_8_sign rs m x base ofs: + exec_store_reg Mint8unsigned rs m x base ofs = exec_store_reg Mint8signed rs m x base ofs. +Proof. + unfold exec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_reg_16_sign rs m x base ofs: + exec_store_reg Mint16unsigned rs m x base ofs = exec_store_reg Mint16signed rs m x base ofs. +Proof. + unfold exec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + +Lemma transl_store_memory_access2_ok: + forall addr chunk args src k c rs a m m', + addr = Aindexed2 -> + transl_store chunk addr args src k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr mr0 mro ro, + args = mr0 :: mro :: nil + /\ preg_of mro = IR ro + /\ preg_of src = IR rr + /\ transl_memory_access2 mk_instr addr args k = OK c + /\ (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk' rs m rr base ro) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros ? TR ? ?. + unfold transl_store in TR. subst addr. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ ArgsInv; reflexivity + | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRR _ x)); simpl; reflexivity + | eauto ]. + - simpl. intros. eapply exec_store_reg_8_sign. + - simpl. intros. eapply exec_store_reg_16_sign. +Qed. + Lemma transl_store_correct: forall chunk addr args src k c (rs: regset) m a m', transl_store chunk addr args src k = OK c -> @@ -2060,8 +2186,10 @@ Proof. rewrite D in STORE; clear D; eapply transl_store_access_correct; eauto with asmgen; try congruence; destruct rr; try discriminate; destruct src; try discriminate. - admit. -Admitted. + - exploit transl_store_memory_access2_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). + eapply transl_store_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. + destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. +Qed. Lemma make_epilogue_correct: forall ge0 f m stk soff cs m' ms rs k tm, diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 77014bdc..c5f432a6 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -100,7 +100,7 @@ Lemma exec_load_offset_pc_var: exec_load_offset ge t rs m rd ra ofs = Next rs' m' -> exec_load_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_load_offset in *. unfold exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. + intros. unfold exec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - discriminate. @@ -111,7 +111,7 @@ Lemma exec_load_reg_pc_var: 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 exec_load in *. rewrite Pregmap.gso; try discriminate. destruct (rs ro); try discriminate. + intros. unfold exec_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. @@ -122,7 +122,7 @@ Lemma exec_store_offset_pc_var: exec_store_offset ge t rs m rd ra ofs = Next rs' m' -> exec_store_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_store_offset in *. unfold exec_store in *. rewrite Pregmap.gso; try discriminate. + intros. unfold exec_store_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. @@ -134,8 +134,7 @@ Lemma exec_store_reg_pc_var: 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 exec_store in *. rewrite Pregmap.gso; try discriminate. - destruct (rs ro); try discriminate. + intros. unfold exec_store_reg in *. rewrite Pregmap.gso; try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. - discriminate. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index ed8edfde..d0e05389 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -943,10 +943,10 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - 1-10: try (unfold exec_load_offset in H1; destruct (eval_offset ge ofs); try discriminate; unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold exec_load_reg in H1; destruct (rs1 rofs); try discriminate; unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold exec_store_offset in H1; destruct (eval_offset ge ofs); try discriminate; unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 1-10: try (unfold exec_store_reg in H1; destruct (rs1 rofs); try discriminate; unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. + 1-10: try (unfold exec_load_offset in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + 1-10: try (unfold exec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + 1-10: try (unfold exec_store_offset in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + 1-10: try (unfold exec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - 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. -- cgit From 3c3d7d77bcce5bdf3b0c8dd786b2656604fb54da Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 3 Apr 2019 16:49:44 +0200 Subject: adaptation de quelques vieux lemmes pour la nouvelle traduction --- mppa_k1c/Machblockgenproof.v | 145 +++++++++++++++++++++++++------------------ 1 file changed, 84 insertions(+), 61 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index eb330e99..07718ede 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -195,13 +195,14 @@ Qed. Definition concat (h: list label) (c: code): code := match c with - | nil => {| header := h; body := nil; exit := None |}::nil + | nil => empty_bblock::nil | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' end. Ltac subst_is_trans_code H := rewrite is_trans_code_inv in H; - rewrite <- H in * |- *. + rewrite <- H in * |- *; + rewrite <- is_trans_code_inv in H. Lemma find_label_transcode_preserved: forall l c c', @@ -325,6 +326,13 @@ Proof. omega. Admitted. (* A FINIR *) + +Lemma size_nonzero c b bl: + is_trans_code c (b :: bl) -> size b <> 0. +Proof. + intros H; inversion H; subst. +Admitted. (* A FINIR *) + Axiom TODO: False. (* a éliminer *) Local Hint Resolve dist_end_block_code_simu_mid_block. @@ -348,14 +356,22 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. +Inductive is_first_bblock b c blc: Prop := + | Tr_dummy_nil: b = empty_bblock -> c=nil -> blc = nil -> is_first_bblock b c blc + | Tr_trans_code: is_trans_code c (b::blc) -> is_first_bblock b c blc + . + +Lemma star_step_simu_body_step s f sp c bl: + is_trans_code c bl -> forall b blc rs m t s', + bl=b::blc -> + (header b)=nil -> + starN (Mach.step (inv_trans_rao rao)) ge (length (body b)) (Mach.State s f sp c rs m) t s' -> + exists c' rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp (body b) rs m rs' m' /\ is_first_bblock {| header := nil; body:=nil; exit := exit b |} c' blc. +Proof. + induction 1; intros b blc rs m t s' X; inversion X; subst; clear X. +Admitted. (* A FINIR *) (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? -Lemma star_step_simu_body_step s f sp c: - forall (p:bblock_body) c' rs m t s', - to_bblock_body c = (p, c') -> - starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' -> - exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp p rs m rs' m'. -Proof. induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. * (* nil *) inversion_clear H; simpl; intros X; inversion_clear X. @@ -392,8 +408,7 @@ Proof. elim TODO. (* A FAIRE *) + intros H r; constructor 1; intro X; inversion X. Qed. - -(* VIELLES PREUVES -- UTILE POUR S'INSPIRER ??? +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? constructor 1; simpl. + intros (t0 & s1' & H0) t s'. rewrite! trans_code_equation. @@ -408,7 +423,9 @@ Qed. inversion H2; subst; simpl; eauto. + intros H r; constructor 1; intro X; inversion X. Qed. +*) +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Lemma step_simu_cfi_step: forall c e c' stk f sp rs m t s' b lb', to_bblock_exit c = (Some e, c') -> @@ -445,12 +462,18 @@ Proof. rewrite parent_sp_preserved in H8; subst; auto. rewrite parent_ra_preserved in H9; subst; auto. Qed. +*) - -Lemma step_simu_exit_step c e c' stk f sp rs m t s' b: - to_bblock_exit c = (e, c') -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s' -> - exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::trans_code c') rs m) t s2 /\ match_states s' s2. +Lemma step_simu_exit_step c stk f sp rs m t s1 b blc b': + is_trans_code c (b::blc) -> + (header b)=nil -> + (body b)=nil -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt (exit b)) (Mach.State stk f sp c rs m) t s1 -> + exists c' s2, exit_step rao tge (exit b) (State (trans_stack stk) f sp (b'::blc) rs m) t s2 /\ match_states s1 s2 /\ is_trans_code c' blc. +Proof. + inversion_clear 1. (* A FINIR *) +Admitted. +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Proof. intros H1 H2; destruct e as [ e |]; inversion_clear H2. + (* Some *) inversion H0; clear H0; subst. autorewrite with trace_rewrite. @@ -463,11 +486,17 @@ Proof. inversion_clear H1. eapply ex_intro; intuition eauto; try eapply match_states_trans_state. Qed. +*) -Lemma step_simu_header st f sp rs m s c: forall h c' t, - (h, c') = to_bblock_header c -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. +Lemma step_simu_header st f sp rs m s c bl: + is_trans_code c bl -> forall b blc t, bl=b::blc -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length (header b)) (Mach.State st f sp c rs m) t s -> + exists c', s = Mach.State st f sp c' rs m /\ t = E0 /\ is_first_bblock {| header := nil; body:=body b; exit := exit b |} c' blc. Proof. + induction 1; intros b blc t X; inversion X; subst; clear X. +Admitted. + +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? induction c as [ | i c]; simpl; intros h c' t H. - inversion_clear H. simpl; intros H; inversion H; auto. - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). @@ -475,7 +504,7 @@ Proof. injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. exploit IHc; eauto. -Qed. +Qed. *) Lemma simu_end_block: @@ -485,57 +514,51 @@ Lemma simu_end_block: Proof. destruct s1; simpl. + (* State *) - unfold dist_end_block_code. - remember (trans_code _) as bl. - rewrite <- is_trans_code_inv in * |-. - intros t s1' H. - inversion Heqbl as [| | |]; subst; simpl in * |- *; (* inversion vs induction ?? *) - elim TODO. (* A FAIRE *) - - (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - - destruct c as [|i c]; simpl; try ( (* nil => absurd *) - unfold dist_end_block_code; simpl; - intros t s1' H; inversion_clear H; - inversion_clear H0; fail - ). - - intros t s1' H. - - remember (_::_) as c0. remember (trans_code c0) as tc0. - - (* tc0 cannot be nil *) - destruct tc0; try - ( exploit (trans_code_nonil c0); subst; auto; try discriminate; intro H0; contradict H0 ). - - assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))). + remember (trans_code _) as tc. + rewrite <- is_trans_code_inv in Heqtc. + intros t s1 H. + destruct tc as [|b bl]. + { (* nil => absurd *) + inversion Heqtc. subst. + unfold dist_end_block_code; simpl. + inversion_clear H; + inversion_clear H0. + } + assert (X: Datatypes.S (dist_end_block_code c) = (size b)). { - unfold dist_end_block_code. remember (size _) as siz. - assert (siz <> 0%nat). rewrite Heqsiz; subst; apply to_bblock_nonil with (c0 := c) (i := i); auto. + unfold dist_end_block_code. + subst_is_trans_code Heqtc. + lapply (size_nonzero c b bl); auto. omega. } - - (* decomposition of starN in 3 parts: header + body + exit *) rewrite X in H; unfold size in H. - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1 [H0 [H3 H4]]]]]. + destruct b as [bh bb be]; simpl in * |- *. + (* decomposition of starN in 3 parts: header + body + exit *) + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1' [H0 [H3 H4]]]]]. subst t; clear X H. - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s0 [H [H1 H2]]]]]. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s1'' [H [H1 H2]]]]]. subst t3; clear H0. + (* header steps *) + exploit step_simu_header; eauto. + clear c Heqtc H; simpl; intros (c & X1 & X2 & X3); subst. + destruct X3 as [H|Heqtc]. + { subst. inversion H. subst. simpl in * |-. + inversion H1. subst. + inversion H3. subst. + autorewrite with trace_rewrite. + eapply ex_intro; intuition eauto. + eapply exec_bblock; simpl; eauto. + } + autorewrite with trace_rewrite. + (* body steps *) + exploit (star_step_simu_body_step); eauto. + clear H1; simpl; intros (rs' & m' & X1 & X2 & X3 & X4 & X5); subst. + elim TODO. (* A FAIRE *) + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER !!! - unfold to_bblock in * |- *. - (* naming parts of block "b" *) - remember (to_bblock_header c0) as hd. destruct hd as [hb c1]. - remember (to_bblock_body c1) as bb. destruct bb as [bb c2]. - remember (to_bblock_exit c2) as exb. destruct exb as [exb c3]. - simpl in * |- *. - - exploit trans_code_step; eauto. intro EQ. destruct EQ as (EQH & EQB & EQE & EQTB0). - subst hb bb exb. - - (* header opt step *) + (* header steps *) exploit step_simu_header; eauto. intros [X1 X2]; subst s0 t1. - autorewrite with trace_rewrite. (* body steps *) exploit (star_step_simu_body_step); eauto. clear H1; intros [rs' [m' [H0 [H1 H2]]]]. -- cgit From ecd4e7a1e28f7f20c1a0c8aaebbef3217a75d28f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 3 Apr 2019 16:59:20 +0200 Subject: Load/Store reg-reg are now proven everywhere --- mppa_k1c/Asmblockdeps.v | 122 +++++++++++++++++++++--------------------------- mppa_k1c/Asmvliw.v | 38 ++++++--------- 2 files changed, 68 insertions(+), 92 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index ac8fa6bd..a06657a8 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -127,25 +127,20 @@ Definition arith_eval (ao: arith_op) (l: list value) := | _, _ => None end. -Definition exec_load_deps (chunk: memory_chunk) (m: mem) - (v: val) (ptr: ptrofs) := - match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => None - | Some vl => Some (Val vl) - end -. - Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ge ofs) with - | OK ptr => exec_load_deps chunk m v ptr + | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with + | None => None + | Some vl => Some (Val vl) + end | _ => None end. Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := - match vo with - | Vptr _ ofs => exec_load_deps chunk m v ofs - | _ => None + match Mem.loadv chunk m (Val.addl v vo) with + | None => None + | Some vl => Some (Val vl) end. Definition load_eval (lo: load_op) (l: list value) := @@ -155,25 +150,20 @@ Definition load_eval (lo: load_op) (l: list value) := | _, _ => None end. -Definition exec_store_deps (chunk: memory_chunk) (m: mem) - (vs va: val) (ptr: ptrofs) := - match Mem.storev chunk m (Val.offset_ptr va ptr) vs with - | None => None - | Some m' => Some (Memstate m') - end -. - Definition exec_store_deps_offset (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ge ofs) with - | OK ptr => exec_store_deps chunk m vs va ptr + | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with + | None => None + | Some m' => Some (Memstate m') + end | _ => None end. Definition exec_store_deps_reg (chunk: memory_chunk) (m: mem) (vs va vo: val) := - match vo with - | Vptr _ ofs => exec_store_deps chunk m vs va ofs - | _ => None + match Mem.storev chunk m (Val.addl va vo) vs with + | None => None + | Some m' => Some (Memstate m') end. Definition store_eval (so: store_op) (l: list value) := @@ -831,47 +821,43 @@ Proof. - simpl in H. inv H. simpl macro_run. eapply trans_arith_correct; eauto. (* Load *) - - simpl in H. admit. - (* destruct i. + - simpl in H. destruct i. (* Load Offset *) + destruct i. all: - unfold exec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_load in H; + unfold exec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; eexists; split; try split; [ - simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); unfold exec_load_deps; simpl in MEML; rewrite MEML; reflexivity + simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); simpl in MEML; rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. (* Load Reg *) + destruct i. all: - unfold exec_load_reg in H; destruct (rs rofs) eqn:ROFS; try discriminate; unfold exec_load in H; - destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; [ - simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold exec_load_deps_reg; rewrite ROFS; - unfold exec_load_deps; simpl in MEML; rewrite MEML; reflexivity + unfold exec_load_reg in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; + eexists; split; try split; + [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold exec_load_deps_reg; simpl in MEML; rewrite MEML; reflexivity | Simpl - | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. *) + | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. (* Store *) - - simpl in H. admit. - (* destruct i. + - simpl in H. destruct i. (* Store Offset *) + destruct i. all: - unfold exec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; unfold exec_store in H; + unfold exec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps; simpl in MEML; rewrite MEML; reflexivity + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); rewrite (H1 rs0); simpl in MEML; rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl ]. (* Store Reg *) + destruct i. all: - unfold exec_store_reg in H; destruct (rs rofs) eqn:ROFS; try discriminate; unfold exec_store in H; + unfold exec_store_reg in H; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; eexists; split; try split; - [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps_reg; rewrite ROFS; - unfold exec_store_deps; simpl in MEML; rewrite MEML; reflexivity + [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps_reg; + simpl in MEML; rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl ]. - *) + (* Allocframe *) - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. inv H. inv H0. eexists. split; try split. @@ -896,8 +882,8 @@ Proof. - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv H0. eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. (* Pnop *) - - simpl in H. inv H. inv H0. eexists. split; try split. assumption. assumption. -Admitted. + - simpl in H. inv H. inv H0. eexists. split; try split. assumption. assumption. +Qed. Lemma forward_simu_body: forall bdy ge rs m rs' m' fn s, @@ -1213,23 +1199,23 @@ Proof. (* Load Offset *) + destruct i. all: simpl; rewrite H2; rewrite (H3 ra); unfold exec_load_offset in H0; destruct (eval_offset _ _); auto; - unfold exec_load_deps; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. + simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. (* Load Reg *) - + admit. (* destruct i. all: + + destruct i. all: simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); unfold exec_load_reg in H0; unfold exec_load_deps_reg; - destruct (rs rofs); auto; unfold exec_load in H0; simpl in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. *) + destruct (rs rofs); auto; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. (* PStore *) - destruct i. (* Store Offset *) + destruct i. all: simpl; rewrite H2; rewrite (H3 ra); rewrite (H3 rs0); unfold exec_store_offset in H0; destruct (eval_offset _ _); auto; - simpl in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _); auto; discriminate. + simpl in H0; destruct (Mem.storev _ _ _); auto; discriminate. (* Store Reg *) - + admit. (* destruct i. all: + + destruct i. all: simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); rewrite (H3 rs0); simpl in H0; unfold exec_store_reg in H0; - unfold exec_store_deps_reg; destruct (rs rofs); auto; unfold exec_store in H0; unfold exec_store_deps; - destruct (Mem.storev _ _ _ _); auto; discriminate. *) + unfold exec_store_deps_reg; destruct (rs rofs); auto; + destruct (Mem.storev _ _ _ _); auto; discriminate. (* Pallocframe *) - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. destruct (Mem.alloc _ _ _). simpl in H0. @@ -1243,7 +1229,7 @@ Proof. all: simpl; auto. - simpl. destruct rd; subst; try discriminate. all: simpl; auto. -Admitted. +Qed. Lemma forward_simu_body_stuck: forall bdy ge fn rs m s, @@ -1805,19 +1791,19 @@ Proof. (* Load Offset *) + destruct i; simpl load_chunk in H. all: unfold parexec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - unfold parexec_load in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); unfold exec_load_deps; rewrite MEML; reflexivity + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. (* Load Reg *) + destruct i; simpl load_chunk in H. all: - unfold parexec_load_reg in H; destruct (rsr rofs) eqn:ROFS; try discriminate; - unfold parexec_load in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + unfold parexec_load_reg in H; + destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; eexists; split; try split; - [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); unfold exec_load_deps_reg; rewrite ROFS; - unfold exec_load_deps; rewrite MEML; reflexivity + [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); unfold exec_load_deps_reg; + rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. @@ -1826,19 +1812,19 @@ Proof. (* Store Offset *) + destruct i; simpl store_chunk in H. all: unfold parexec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - unfold parexec_store in H; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); rewrite (H0 rs); unfold exec_store_deps; rewrite MEML; reflexivity + [ simpl; rewrite EVALOFF; rewrite H; rewrite (H0 ra); rewrite (H0 rs); rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl ]. (* Store Reg *) + destruct i; simpl store_chunk in H. all: - unfold parexec_store_reg in H; destruct (rsr rofs) eqn:ROFS; try discriminate; - unfold parexec_store in H; destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; + unfold parexec_store_reg in H; + destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv MSR; inv MSW; eexists; split; try split; - [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); rewrite (H0 rs); unfold exec_store_deps_reg; rewrite ROFS; - unfold exec_store_deps; rewrite MEML; reflexivity + [ simpl; rewrite H; rewrite (H0 rofs); rewrite (H0 ra); rewrite (H0 rs); unfold exec_store_deps_reg; + rewrite MEML; reflexivity | Simpl | intros rr; destruct rr; Simpl ]. @@ -1883,23 +1869,23 @@ Proof. (* Load Offset *) + destruct i; simpl in H0. all: simpl; rewrite H; rewrite (H1 ra); unfold parexec_load_offset in H0; destruct (eval_offset _ _); auto; - unfold parexec_load in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + destruct (Mem.loadv _ _ _); auto; discriminate. (* Load Reg *) + destruct i; simpl in H0. all: simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold parexec_load_reg in H0; unfold exec_load_deps_reg; - destruct (rsr rofs); auto; unfold parexec_load in H0; unfold exec_load_deps; destruct (Mem.loadv _ _ _); auto; discriminate. + destruct (rsr rofs); auto; destruct (Mem.loadv _ _ _); auto; discriminate. (* PStore *) - destruct i. (* Store Offset *) + destruct i; simpl in H0. all: simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); unfold parexec_store_offset in H0; destruct (eval_offset _ _); auto; - unfold parexec_store in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _ _); auto; discriminate. + destruct (Mem.storev _ _ _ _); auto; discriminate. (* Store Reg *) + destruct i; simpl in H0. all: simpl; rewrite H; rewrite (H1 ra); rewrite (H1 rs); rewrite (H1 rofs); unfold parexec_store_reg in H0; unfold exec_store_deps_reg; - destruct (rsr rofs); auto; unfold parexec_store in H0; unfold exec_store_deps; destruct (Mem.storev _ _ _ _); auto; discriminate. + destruct (rsr rofs); auto; destruct (Mem.storev _ _ _ _); auto; discriminate. (* Pallocframe *) - simpl. Simpl. rewrite (H1 SP). rewrite H. destruct (Mem.alloc _ _ _). simpl in H0. destruct (Mem.store _ _ _ _); try discriminate. reflexivity. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index cae79287..956b860b 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -69,44 +69,34 @@ Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := (** * load/store *) (* TODO: factoriser ? *) -Definition parexec_load (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) - (d: ireg) (a: ireg) (ptr: ptrofs) := - match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => Stuck - | Some v => Next (rsw#d <- v) mw - end -. - Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := match (eval_offset ge ofs) with - | OK ptr => parexec_load chunk rsr rsw mr mw d a ptr + | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with + | None => Stuck + | Some v => Next (rsw#d <- v) mw + end | _ => Stuck end. Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := - match (rsr ro) with - | Vptr _ ofs => parexec_load chunk rsr rsw mr mw d a ofs - | _ => Stuck - end. - -Definition parexec_store (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) - (s: ireg) (a: ireg) (ptr: ptrofs) := - match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with + match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with | None => Stuck - | Some m' => Next rsw m' - end -. + | Some v => Next (rsw#d <- v) mw + end. Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := match (eval_offset ge ofs) with - | OK ptr => parexec_store chunk rsr rsw mr mw s a ptr + | OK ptr => match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end | _ => Stuck end. Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := - match (rsr ro) with - | Vptr _ ofs => parexec_store chunk rsr rsw mr mw s a ofs - | _ => Stuck + match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' end. (* rem: parexec_store = exec_store *) -- cgit From 9d286aa671a9c320114337a821fab8677e03558e Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 3 Apr 2019 19:12:21 +0200 Subject: bien meilleure façon de s'inspirer de l'ancienne traduction MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Machblockgenproof.v | 130 ++++++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 71 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 07718ede..0ca23a36 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -195,7 +195,7 @@ Qed. Definition concat (h: list label) (c: code): code := match c with - | nil => empty_bblock::nil + | nil => {| header := h; body := nil; exit := None |}::nil | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' end. @@ -325,6 +325,7 @@ Proof. subst_is_trans_code H. omega. Admitted. (* A FINIR *) +Local Hint Resolve dist_end_block_code_simu_mid_block. Lemma size_nonzero c b bl: @@ -333,9 +334,41 @@ Proof. intros H; inversion H; subst. Admitted. (* A FINIR *) -Axiom TODO: False. (* a éliminer *) +(* TODO: définir les predicats inductifs suivants de façon à prouver le lemme [is_trans_code_decompose] ci-dessous *) -Local Hint Resolve dist_end_block_code_simu_mid_block. +Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := + . (* A FAIRE *) + +Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := + . (* A FAIRE *) + +Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := + . (* A FAIRE *) + +Lemma trans_code_decompose c bc: + is_trans_code c bc -> forall b blc, bc=(b::blc) -> + exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 blc. +Proof. + induction 1; intros b blc X; inversion X; subst; clear X. +Admitted. + +Lemma step_simu_header st f sp rs m s c h c' t: + is_header h c c' -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> + s = Mach.State st f sp c' rs m /\ t = E0. +Proof. + induction 1. (* A FINIR *) +Admitted. +(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? + induction c as [ | i c]; simpl; intros h c' t H. + - inversion_clear H. simpl; intros H; inversion H; auto. + - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). + remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0]. + injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. + inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. + exploit IHc; eauto. +Qed. +*) Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): trans_inst i = MB_basic bi -> @@ -356,19 +389,12 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. -Inductive is_first_bblock b c blc: Prop := - | Tr_dummy_nil: b = empty_bblock -> c=nil -> blc = nil -> is_first_bblock b c blc - | Tr_trans_code: is_trans_code c (b::blc) -> is_first_bblock b c blc - . - -Lemma star_step_simu_body_step s f sp c bl: - is_trans_code c bl -> forall b blc rs m t s', - bl=b::blc -> - (header b)=nil -> - starN (Mach.step (inv_trans_rao rao)) ge (length (body b)) (Mach.State s f sp c rs m) t s' -> - exists c' rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp (body b) rs m rs' m' /\ is_first_bblock {| header := nil; body:=nil; exit := exit b |} c' blc. +Lemma star_step_simu_body_step s f sp c bdy c': + is_body bdy c c' -> forall rs m t s', + starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. Proof. - induction 1; intros b blc rs m t s' X; inversion X; subst; clear X. + induction 1. Admitted. (* A FINIR *) (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? @@ -397,6 +423,8 @@ 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. + +Axiom TODO: False. (* a éliminer *) Lemma match_states_concat_trans_code st f sp c rs m h: match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). Proof. @@ -464,14 +492,12 @@ Proof. Qed. *) -Lemma step_simu_exit_step c stk f sp rs m t s1 b blc b': - is_trans_code c (b::blc) -> - (header b)=nil -> - (body b)=nil -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt (exit b)) (Mach.State stk f sp c rs m) t s1 -> - exists c' s2, exit_step rao tge (exit b) (State (trans_stack stk) f sp (b'::blc) rs m) t s2 /\ match_states s1 s2 /\ is_trans_code c' blc. +Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: + is_exit e c c' -> is_trans_code c' blc -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> + exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. Proof. - inversion_clear 1. (* A FINIR *) + destruct 1. (* A FINIR *) Admitted. (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Proof. @@ -488,25 +514,6 @@ Proof. Qed. *) -Lemma step_simu_header st f sp rs m s c bl: - is_trans_code c bl -> forall b blc t, bl=b::blc -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length (header b)) (Mach.State st f sp c rs m) t s -> - exists c', s = Mach.State st f sp c' rs m /\ t = E0 /\ is_first_bblock {| header := nil; body:=body b; exit := exit b |} c' blc. -Proof. - induction 1; intros b blc t X; inversion X; subst; clear X. -Admitted. - -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - induction c as [ | i c]; simpl; intros h c' t H. - - inversion_clear H. simpl; intros H; inversion H; auto. - - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). - remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0]. - injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. - inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. - exploit IHc; eauto. -Qed. -*) - Lemma simu_end_block: forall s1 t s1', starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> @@ -532,44 +539,25 @@ Proof. omega. } rewrite X in H; unfold size in H. - destruct b as [bh bb be]; simpl in * |- *. (* decomposition of starN in 3 parts: header + body + exit *) - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1' [H0 [H3 H4]]]]]. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as (t3&t4&s1'&H0&H3&H4). subst t; clear X H. - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s1'' [H [H1 H2]]]]]. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as (t1&t2&s1''&H&H1&H2). subst t3; clear H0. + exploit trans_code_decompose; eauto. clear Heqtc. + intros (c0&c1&c2&Hc0&Hc1&Hc2&Heqtc). (* header steps *) exploit step_simu_header; eauto. - clear c Heqtc H; simpl; intros (c & X1 & X2 & X3); subst. - destruct X3 as [H|Heqtc]. - { subst. inversion H. subst. simpl in * |-. - inversion H1. subst. - inversion H3. subst. - autorewrite with trace_rewrite. - eapply ex_intro; intuition eauto. - eapply exec_bblock; simpl; eauto. - } - autorewrite with trace_rewrite. - (* body steps *) - exploit (star_step_simu_body_step); eauto. - clear H1; simpl; intros (rs' & m' & X1 & X2 & X3 & X4 & X5); subst. - elim TODO. (* A FAIRE *) - (* VIELLE PREUVE -- UTILE POUR S'INSPIRER !!! - - (* header steps *) - exploit step_simu_header; eauto. - intros [X1 X2]; subst s0 t1. + clear H; intros [X1 X2]; subst. (* body steps *) exploit (star_step_simu_body_step); eauto. - clear H1; intros [rs' [m' [H0 [H1 H2]]]]. - subst s1 t2. autorewrite with trace_rewrite. + clear H1; intros (rs'&m'&H0&H1&H2). subst. + autorewrite with trace_rewrite. (* exit step *) - subst tc0. - exploit step_simu_exit_step; eauto. clear H3. - intros (s2' & H3 & H4). + exploit step_simu_exit_step; eauto. + clear H3; intros (s2' & H3 & H4). eapply ex_intro; intuition eauto. - eapply exec_bblock; eauto. -*) + (* VIELLE PREUVE: eapply exec_bblock; eauto. *) + (* Callstate *) intros t s1' H; inversion_clear H. eapply ex_intro; constructor 1; eauto. @@ -591,7 +579,7 @@ Proof. inversion H1; subst; clear H1. inversion_clear H0; simpl. eapply exec_return. -Qed. +Admitted. (* A FIXER *) Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). -- cgit From 4032ed3192424a23dbb0a4f3bd2a539b22625168 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 3 Apr 2019 21:00:46 +0200 Subject: problem in ValueAOp --- mppa_k1c/Op.v | 6 +++--- mppa_k1c/SelectLong.vp | 8 +++++--- mppa_k1c/SelectLongproof.v | 3 ++- mppa_k1c/ValueAOp.v | 4 ++-- 4 files changed, 12 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 10e4a350..74788387 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -272,12 +272,12 @@ Definition select (v0 : val) (v1 : val) (vselect : val) : val := Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := match vselect with - | Vlong iselect => + | Vint iselect => match v0 with | Vlong i0 => match v1 with | Vlong i1 => - Vlong (if Int64.cmp Ceq Int64.zero iselect + Vlong (if Int.cmp Ceq Int.zero iselect then i0 else i1) | _ => Vundef @@ -607,7 +607,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocmp c => (type_of_condition c, Tint) | Oselect => (Tint :: Tint :: Tint :: nil, Tint) - | Oselectl => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Oselectl => (Tlong :: Tlong :: Tint :: nil, Tlong) end. Definition type_of_addressing (addr: addressing) : list typ := diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 60b8f094..7fefe594 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -285,7 +285,10 @@ Nondetfunction orl (e1: expr) (e2: expr) := | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 | 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) + | t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil) + end. + + (* | (Eop Oandl ((Eop Ocast32signed ((Eop Oneg ((Eop (Ocmp (Ccomplimm Ceq zero0)) (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), @@ -298,8 +301,7 @@ Nondetfunction orl (e1: expr) (e2: expr) := then Eop Oselectl (v0:::v1:::y0:::Enil) else Eop Oorl (e1:::e2:::Enil) | _, _ => Eop Oorl (e1:::e2:::Enil) - end. - + *) Nondetfunction xorlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 11804d2e..e18de2ee 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -452,6 +452,7 @@ 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. @@ -525,7 +526,7 @@ Proof. rewrite Int64.and_mone. rewrite Int64.and_zero. rewrite Int64.or_zero. - reflexivity. + reflexivity. *) - TrivialExists. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 9c851573..de2fd422 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -273,8 +273,8 @@ Proof. destruct a1; destruct a0; eauto; constructor. (* selectl *) - inv H2; simpl; try constructor. - + destruct (Int64.eq _ _); apply binop_long_sound; trivial. - + destruct (Int64.eq _ _); + + destruct (Int.eq _ _); apply binop_long_sound; trivial. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. Qed. -- cgit From 4518486a771055e633aa050141d9721353d542d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 3 Apr 2019 21:59:22 +0200 Subject: ternary ops in AES and TEA --- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof1.v | 4 ++-- mppa_k1c/SelectLong.vp | 2 +- mppa_k1c/ValueAOp.v | 9 +++++---- 4 files changed, 9 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 6315192c..a7e3c8ef 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -741,7 +741,7 @@ Definition transl_op do r0 <- ireg_of a0; do r1 <- ireg_of a1; do rS <- ireg_of aS; - OK (Pcmove BTdnez r0 rS r1 ::i k) + OK (Pcmove BTwnez r0 rS r1 ::i k) | _, _ => Error(msg "Asmgenblock.transl_op") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index d90b73e2..99ab1b91 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1661,8 +1661,8 @@ Opaque Int.eq. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. simpl. - rewrite int64_eq_comm. - destruct (Int64.eq i Int64.zero); simpl; rewrite Pregmap.gss; constructor. + rewrite int_eq_comm. + destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. Qed. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 7fefe594..f8f5bf3b 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -286,6 +286,7 @@ 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 Oorl (e1:::e2:::Enil) end. (* @@ -300,7 +301,6 @@ Nondetfunction orl (e1: expr) (e2: expr) := && Int64.eq zero1 Int64.zero then Eop Oselectl (v0:::v1:::y0:::Enil) else Eop Oorl (e1:::e2:::Enil) - | _, _ => Eop Oorl (e1:::e2:::Enil) *) Nondetfunction xorlimm (n1: int64) (e2: expr) := diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index de2fd422..da108ada 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -53,8 +53,8 @@ Definition select (v0 v1 vselect : aval) : aval := Definition selectl (v0 v1 vselect : aval) : aval := match vselect with - | L iselect => - if Int64.eq Int64.zero iselect + | I iselect => + if Int.eq Int.zero iselect then binop_long (fun x0 x1 => x0) v0 v1 else binop_long (fun x0 x1 => x1) v0 v1 | _ => Vtop @@ -274,8 +274,9 @@ Proof. (* selectl *) - inv H2; simpl; try constructor. + destruct (Int.eq _ _); apply binop_long_sound; trivial. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. Qed. End SOUNDNESS. -- cgit From 524678ff9a521433ff0b5af2a3986c1e385e699e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 3 Apr 2019 22:15:21 +0200 Subject: for floats and doubles, asmgen support --- mppa_k1c/Asmblockgen.v | 12 ++++------- mppa_k1c/Op.v | 54 +++++++++++++++++++++++++++++++++++++++++++++++++- mppa_k1c/ValueAOp.v | 41 ++++++++++++++++++++++++++++++++------ 3 files changed, 92 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index a7e3c8ef..ad01ff89 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -729,14 +729,10 @@ Definition transl_op do rd <- ireg_of res; transl_cond_op cmp rd args k - | Oselect, a0 :: a1 :: aS :: nil => - assertion (mreg_eq a0 res); - do r0 <- ireg_of a0; - do r1 <- ireg_of a1; - do rS <- ireg_of aS; - OK (Pcmove BTwnez r0 rS r1 ::i k) - - | Oselectl, a0 :: a1 :: aS :: nil => + | Oselect, a0 :: a1 :: aS :: nil + | Oselectl, a0 :: a1 :: aS :: nil + | Oselectf, a0 :: a1 :: aS :: nil + | Oselectfs, a0 :: a1 :: aS :: nil => assertion (mreg_eq a0 res); do r0 <- ireg_of a0; do r1 <- ireg_of a1; diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 74788387..5afd0cb9 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -183,7 +183,9 @@ Inductive operation : Type := (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) | Oselect (**r [rd = if r3 then r2 else r1] *) - | Oselectl. (**r [rd = if r3 then r2 else r1] *) + | Oselectl (**r [rd = if r3 then r2 else r1] *) + | Oselectf (**r [rd = if r3 then r2 else r1] *) + | Oselectfs. (**r [rd = if r3 then r2 else r1] *) (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -287,6 +289,40 @@ Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := | _ => Vundef end. +Definition selectf (v0 : val) (v1 : val) (vselect : val) : val := + match vselect with + | Vint iselect => + match v0 with + | Vfloat i0 => + match v1 with + | Vfloat i1 => + Vfloat (if Int.cmp Ceq Int.zero iselect + then i0 + else i1) + | _ => Vundef + end + | _ => Vundef + end + | _ => Vundef + end. + +Definition selectfs (v0 : val) (v1 : val) (vselect : val) : val := + match vselect with + | Vint iselect => + match v0 with + | Vsingle i0 => + match v1 with + | Vsingle i1 => + Vsingle (if Int.cmp Ceq Int.zero iselect + then i0 + else i1) + | _ => Vundef + end + | _ => Vundef + end + | _ => Vundef + end. + Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -417,6 +453,8 @@ Definition eval_operation | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) | Oselect, v0::v1::vselect::nil => Some (select v0 v1 vselect) | Oselectl, v0::v1::vselect::nil => Some (selectl v0 v1 vselect) + | Oselectf, v0::v1::vselect::nil => Some (selectf v0 v1 vselect) + | Oselectfs, v0::v1::vselect::nil => Some (selectfs v0 v1 vselect) | _, _ => None end. @@ -608,6 +646,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oselect => (Tint :: Tint :: Tint :: nil, Tint) | Oselectl => (Tlong :: Tlong :: Tint :: nil, Tlong) + | Oselectf => (Tfloat :: Tfloat :: Tint :: nil, Tfloat) + | Oselectfs => (Tsingle :: Tsingle :: Tint :: nil, Tsingle) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -847,6 +887,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. (* selectl *) - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. + (* selectf *) + - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. + (* selectfs *) + - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. Qed. End SOUNDNESS. @@ -1381,6 +1425,14 @@ Proof. - inv H3; simpl; try constructor. inv H4; simpl; try constructor. inv H2; simpl; constructor. + (* selectf *) + - inv H3; simpl; try constructor. + inv H4; simpl; try constructor. + inv H2; simpl; constructor. + (* selectfs *) + - inv H3; simpl; try constructor. + inv H4; simpl; try constructor. + inv H2; simpl; constructor. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index da108ada..122249a4 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -59,6 +59,24 @@ Definition selectl (v0 v1 vselect : aval) : aval := else binop_long (fun x0 x1 => x1) v0 v1 | _ => Vtop end. + +Definition selectf (v0 v1 vselect : aval) : aval := + match vselect with + | I iselect => + if Int.eq Int.zero iselect + then binop_float (fun x0 x1 => x0) v0 v1 + else binop_float (fun x0 x1 => x1) v0 v1 + | _ => Vtop + end. + +Definition selectfs (v0 v1 vselect : aval) : aval := + match vselect with + | I iselect => + if Int.eq Int.zero iselect + then binop_single (fun x0 x1 => x0) v0 v1 + else binop_single (fun x0 x1 => x1) v0 v1 + | _ => Vtop + end. Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with @@ -186,6 +204,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocmp c, _ => of_optbool (eval_static_condition c vl) | Oselect, v0::v1::vselect::nil => select v0 v1 vselect | Oselectl, v0::v1::vselect::nil => selectl v0 v1 vselect + | Oselectf, v0::v1::vselect::nil => selectf v0 v1 vselect + | Oselectfs, v0::v1::vselect::nil => selectfs v0 v1 vselect | _, _ => Vbot end. @@ -265,18 +285,27 @@ Proof. (* select *) - inv H2; simpl; try constructor. + destruct (Int.eq _ _); apply binop_int_sound; trivial. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); - destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. (* selectl *) - inv H2; simpl; try constructor. + destruct (Int.eq _ _); apply binop_long_sound; trivial. + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + (* selectf *) + - inv H2; simpl; try constructor. + + destruct (Int.eq _ _); apply binop_float_sound; trivial. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + (* selectfs *) + - inv H2; simpl; try constructor. + + destruct (Int.eq _ _); apply binop_single_sound; trivial. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. Qed. End SOUNDNESS. -- cgit From ca34ea47f863c074a9d0ca890097786c5829267c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 3 Apr 2019 22:36:22 +0200 Subject: ternary ops for float/double --- mppa_k1c/Asmblockgenproof1.v | 28 ++++++++++++++++++++++++++++ mppa_k1c/Machregs.v | 2 +- mppa_k1c/NeedOp.v | 44 +++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 72 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 99ab1b91..f75f0bd3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1665,6 +1665,34 @@ Opaque Int.eq. destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. +- (* Oselectf *) + econstructor; split. + + eapply exec_straight_one. + simpl; reflexivity. + + split. + * unfold selectl. + destruct (rs x1) eqn:eqX1; try constructor. + destruct (rs x) eqn:eqX; try constructor. + destruct (rs x0) eqn:eqX0; try constructor. + simpl. + rewrite int_eq_comm. + destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + * intros. + rewrite Pregmap.gso; congruence. +- (* Oselectfs *) + econstructor; split. + + eapply exec_straight_one. + simpl; reflexivity. + + split. + * unfold selectl. + destruct (rs x1) eqn:eqX1; try constructor. + destruct (rs x) eqn:eqX; try constructor. + destruct (rs x0) eqn:eqX0; try constructor. + simpl. + rewrite int_eq_comm. + destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + * intros. + rewrite Pregmap.gso; congruence. Qed. (** Memory accesses *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index f494c67d..f89f952f 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -209,7 +209,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect | Oselectl => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect | Oselectl | Oselectf | Oselectfs => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index a6ecb820..f3ce8361 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -117,7 +117,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c - | Oselect | Oselectl => op3 (default nv) + | Oselect | Oselectl | Oselectf | Oselectfs => op3 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -227,6 +227,44 @@ Proof. constructor. Qed. +Lemma selectf_sound: + forall v0 w0 v1 w1 v2 w2 x, + vagree v0 w0 (default x) -> + vagree v1 w1 (default x) -> + vagree v2 w2 (default x) -> + vagree (selectf v0 v1 v2) (selectf w0 w1 w2) x. +Proof. + unfold default; intros. + destruct x; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + inv H. inv H0. inv H1. simpl. + constructor. +Qed. + +Lemma selectfs_sound: + forall v0 w0 v1 w1 v2 w2 x, + vagree v0 w0 (default x) -> + vagree v1 w1 (default x) -> + vagree v2 w2 (default x) -> + vagree (selectfs v0 v1 v2) (selectfs w0 w1 w2) x. +Proof. + unfold default; intros. + destruct x; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + - destruct v2; simpl; trivial. + destruct v0; simpl; trivial. + destruct v1; simpl; trivial. + inv H. inv H0. inv H1. simpl. + constructor. +Qed. + Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. @@ -283,6 +321,10 @@ Proof. - apply select_sound; trivial. (* selectl *) - apply selectl_sound; trivial. + (* selectf *) +- apply selectf_sound; trivial. + (* selectfs *) +- apply selectfs_sound; trivial. Qed. Lemma operation_is_redundant_sound: -- cgit From 70db0c8a5cd5fb21e92de32cc4eb5774baf60610 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 06:07:00 +0200 Subject: prepare for conditions in cmove --- mppa_k1c/Asmblockgenproof1.v | 8 ++++---- mppa_k1c/NeedOp.v | 8 ++++---- mppa_k1c/Op.v | 33 ++++++++++++++++++++++++--------- mppa_k1c/SelectOpproof.v | 4 ++-- 4 files changed, 34 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index f75f0bd3..698d64d6 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1642,7 +1642,7 @@ Opaque Int.eq. + eapply exec_straight_one. simpl; reflexivity. + split. - * unfold select. + * unfold eval_select. destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. @@ -1656,7 +1656,7 @@ Opaque Int.eq. + eapply exec_straight_one. simpl; reflexivity. + split. - * unfold selectl. + * unfold eval_selectl. destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. @@ -1670,7 +1670,7 @@ Opaque Int.eq. + eapply exec_straight_one. simpl; reflexivity. + split. - * unfold selectl. + * unfold eval_selectf. destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. @@ -1684,7 +1684,7 @@ Opaque Int.eq. + eapply exec_straight_one. simpl; reflexivity. + split. - * unfold selectl. + * unfold eval_selectfs. destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index f3ce8361..ee3c4e27 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -192,7 +192,7 @@ Lemma select_sound: vagree v0 w0 (default x) -> vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (select v0 v1 v2) (select w0 w1 w2) x. + vagree (eval_select v0 v1 v2) (eval_select w0 w1 w2) x. Proof. unfold default; intros. destruct x; trivial. @@ -213,7 +213,7 @@ Lemma selectl_sound: vagree v0 w0 (default x) -> vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (selectl v0 v1 v2) (selectl w0 w1 w2) x. + vagree (eval_selectl v0 v1 v2) (eval_selectl w0 w1 w2) x. Proof. unfold default; intros. destruct x; trivial. @@ -232,7 +232,7 @@ Lemma selectf_sound: vagree v0 w0 (default x) -> vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (selectf v0 v1 v2) (selectf w0 w1 w2) x. + vagree (eval_selectf v0 v1 v2) (eval_selectf w0 w1 w2) x. Proof. unfold default; intros. destruct x; trivial. @@ -251,7 +251,7 @@ Lemma selectfs_sound: vagree v0 w0 (default x) -> vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (selectfs v0 v1 v2) (selectfs w0 w1 w2) x. + vagree (eval_selectfs v0 v1 v2) (eval_selectfs w0 w1 w2) x. Proof. unfold default; intros. destruct x; trivial. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 5afd0cb9..551d2dfb 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,6 +51,12 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) +Inductive condition0 : Type := + | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) + | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) + | Ccompl0 (c: comparison) (**r signed 64-bit integer comparison with 0 *) + | Ccomplu0 (c: comparison). (**r unsigned 64-bit integer comparison with 0 *) + (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -237,7 +243,7 @@ Global Opaque eq_condition eq_addressing eq_operation. to lists of values. Return [None] when the computation can trigger an error, e.g. integer division by zero. [eval_condition] returns a boolean, [eval_operation] and [eval_addressing] return a value. *) - + Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 @@ -254,8 +260,17 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) | _, _ => None end. + +Definition eval_condition0 (cond: condition0) (vl: list val) (m: mem): option bool := + match cond, vl with + | Ccomp0 c, v1 :: nil => Val.cmp_bool c v1 (Vint Int.zero) + | Ccompu0 c, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint Int.zero) + | Ccompl0 c, v1 :: nil => Val.cmpl_bool c v1 (Vlong Int64.zero) + | Ccomplu0 c, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) + | _, _ => None + end. -Definition select (v0 : val) (v1 : val) (vselect : val) : val := +Definition eval_select (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with @@ -272,7 +287,7 @@ Definition select (v0 : val) (v1 : val) (vselect : val) : val := | _ => Vundef end. -Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := +Definition eval_selectl (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with @@ -289,7 +304,7 @@ Definition selectl (v0 : val) (v1 : val) (vselect : val) : val := | _ => Vundef end. -Definition selectf (v0 : val) (v1 : val) (vselect : val) : val := +Definition eval_selectf (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with @@ -306,7 +321,7 @@ Definition selectf (v0 : val) (v1 : val) (vselect : val) : val := | _ => Vundef end. -Definition selectfs (v0 : val) (v1 : val) (vselect : val) : val := +Definition eval_selectfs (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => match v0 with @@ -451,10 +466,10 @@ 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, v0::v1::vselect::nil => Some (select v0 v1 vselect) - | Oselectl, v0::v1::vselect::nil => Some (selectl v0 v1 vselect) - | Oselectf, v0::v1::vselect::nil => Some (selectf v0 v1 vselect) - | Oselectfs, v0::v1::vselect::nil => Some (selectfs v0 v1 vselect) + | Oselect, v0::v1::vselect::nil => Some (eval_select v0 v1 vselect) + | Oselectl, v0::v1::vselect::nil => Some (eval_selectl v0 v1 vselect) + | Oselectf, v0::v1::vselect::nil => Some (eval_selectf v0 v1 vselect) + | Oselectfs, v0::v1::vselect::nil => Some (eval_selectfs v0 v1 vselect) | _, _ => None end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 5a19510a..20ba74a1 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -568,7 +568,7 @@ Proof. predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. TrivialExists. simpl in *. - unfold select. + unfold eval_select. f_equal. inv H6. inv H7. @@ -606,7 +606,7 @@ Proof. predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. TrivialExists. simpl in *. - unfold select. + unfold eval_select. f_equal. inv H6. inv H7. -- cgit From 4e17c25f7d6d3c5d7fb13dc0d0c3dacf3fb2830b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 07:43:38 +0200 Subject: working on select --- mppa_k1c/Op.v | 86 ++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 58 insertions(+), 28 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 551d2dfb..15e3eda4 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -57,6 +57,12 @@ Inductive condition0 : Type := | Ccompl0 (c: comparison) (**r signed 64-bit integer comparison with 0 *) | Ccomplu0 (c: comparison). (**r unsigned 64-bit integer comparison with 0 *) +Definition arg_type_of_condition0 (cond: condition0) := + match cond with + | Ccomp0 _ | Ccompu0 _ => Tint + | Ccompl0 _ | Ccomplu0 _ => Tlong + end. + (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -188,7 +194,7 @@ 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 (**r [rd = if r3 then r2 else r1] *) + | Oselect (cond: condition0) (**r [rd = if r3 then r2 else r1] *) | Oselectl (**r [rd = if r3 then r2 else r1] *) | Oselectf (**r [rd = if r3 then r2 else r1] *) | Oselectfs. (**r [rd = if r3 then r2 else r1] *) @@ -211,6 +217,13 @@ Proof. decide equality. Defined. +Definition eq_condition0 (x y: condition0) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. Proof. generalize ident_eq Ptrofs.eq_dec; intros. @@ -219,7 +232,7 @@ 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; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0; intros. decide equality. Defined. @@ -261,26 +274,23 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | _, _ => None end. -Definition eval_condition0 (cond: condition0) (vl: list val) (m: mem): option bool := - match cond, vl with - | Ccomp0 c, v1 :: nil => Val.cmp_bool c v1 (Vint Int.zero) - | Ccompu0 c, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint Int.zero) - | Ccompl0 c, v1 :: nil => Val.cmpl_bool c v1 (Vlong Int64.zero) - | Ccomplu0 c, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) - | _, _ => None +Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := + match cond with + | Ccomp0 c => Val.cmp_bool c v1 (Vint Int.zero) + | Ccompu0 c => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint Int.zero) + | Ccompl0 c => Val.cmpl_bool c v1 (Vlong Int64.zero) + | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) end. -Definition eval_select (v0 : val) (v1 : val) (vselect : val) : val := - match vselect with - | Vint iselect => - match v0 with - | Vint i0 => - match v1 with - | Vint i1 => - Vint (if Int.cmp Ceq Int.zero iselect - then i0 - else i1) - | _ => Vundef +Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := + match v0 with + | Vint i0 => + match v1 with + | Vint i1 => + match (eval_condition0 cond vselect m) with + | Some bval => + Vint (if bval then i1 else i0) + | None => Vundef end | _ => Vundef end @@ -466,7 +476,7 @@ 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, v0::v1::vselect::nil => Some (eval_select v0 v1 vselect) + | (Oselect cond), v0::v1::vselect::nil => Some (eval_select cond v0 v1 vselect m) | Oselectl, v0::v1::vselect::nil => Some (eval_selectl v0 v1 vselect) | Oselectf, v0::v1::vselect::nil => Some (eval_selectf v0 v1 vselect) | Oselectfs, v0::v1::vselect::nil => Some (eval_selectfs v0 v1 vselect) @@ -659,7 +669,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) - | Oselect => (Tint :: Tint :: Tint :: nil, Tint) + | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint) | Oselectl => (Tlong :: Tlong :: Tint :: nil, Tlong) | Oselectf => (Tfloat :: Tfloat :: Tint :: nil, Tfloat) | Oselectfs => (Tsingle :: Tsingle :: Tint :: nil, Tsingle) @@ -899,7 +909,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* cmp *) - destruct (eval_condition cond vl m)... destruct b... (* select *) - - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. + - 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; destruct v2; simpl in *; try discriminate; trivial. (* selectf *) @@ -1066,6 +1083,10 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 + + | Oselect (Ccompu0 _) => negb Archi.ptr64 + | Oselect (Ccomplu0 _) => Archi.ptr64 + | _ => false end. @@ -1074,9 +1095,10 @@ 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. + intros until m2. destruct op; simpl; try congruence; + destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + unfold eval_select, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1204,6 +1226,14 @@ Proof. - inv H3; inv H2; simpl in H0; inv H0; auto. Qed. +Lemma eval_condition0_inj: + forall cond v1 v2 b, + Val.inject f v1 v2 -> + eval_condition0 cond v1 m1 = Some b -> + eval_condition0 cond v2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + Ltac TrivialExists := match goal with | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => @@ -1433,9 +1463,9 @@ Proof. destruct b; simpl; constructor. simpl; constructor. (* select *) - - inv H3; simpl; try constructor. - inv H4; simpl; try constructor. - inv H2; simpl; constructor. + - inv H4; simpl; try constructor. + inv H2; simpl; try constructor. + inv H3; simpl; try constructor. (* selectl *) - inv H3; simpl; try constructor. inv H4; simpl; try constructor. -- cgit From 3b70f4b0eb0d8efde0946ed883072e0f94d5766d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 09:34:05 +0200 Subject: working on select --- mppa_k1c/Op.v | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 15e3eda4..96df5e1f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1233,6 +1233,11 @@ Lemma eval_condition0_inj: eval_condition0 cond v2 m2 = Some b. Proof. intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + - inv H; simpl in *; congruence. + - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. + - inv H; simpl in *; congruence. + - eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +Qed. Ltac TrivialExists := match goal with @@ -1463,9 +1468,25 @@ Proof. destruct b; simpl; constructor. simpl; constructor. (* select *) - - inv H4; simpl; try constructor. - inv H2; simpl; try constructor. - inv H3; simpl; try constructor. + - unfold eval_select. + inv H4; trivial. + inv H2; trivial. + inv H3; trivial. + + destruct (eval_condition0 cond _ m1) eqn:Hcond; trivial. + assert (Hcond' : ((eval_condition0 cond (Vint i1) m2) = Some b)). + * eapply eval_condition0_inj. + constructor. + assumption. + * rewrite Hcond'. constructor. + + destruct (eval_condition0 cond _ m1) eqn:Hcond; trivial. + assert (Hcond' : ((eval_condition0 cond (Vlong i1) m2) = Some b)). + + trivial. + exploit eval_condition0_inj; eauto. + exploit eval_condition0_inj; eauto. + destruct v; trivial. + destruct v0; trivial. + destruct v'; trivial. (* selectl *) - inv H3; simpl; try constructor. inv H4; simpl; try constructor. -- cgit From b7ded97f34c5f0c670f43f2b15e77eb8874a764e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 12:34:11 +0200 Subject: progressing on select --- mppa_k1c/Machregs.v | 2 +- mppa_k1c/Op.v | 26 ++++++++++---------------- 2 files changed, 11 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index f89f952f..daf724ea 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -209,7 +209,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect | Oselectl | Oselectf | Oselectfs => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl | Oselectf | Oselectfs => true | _ => false end. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 96df5e1f..c3ea4baf 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1471,22 +1471,16 @@ Proof. - unfold eval_select. inv H4; trivial. inv H2; trivial. - inv H3; trivial. - + destruct (eval_condition0 cond _ m1) eqn:Hcond; trivial. - assert (Hcond' : ((eval_condition0 cond (Vint i1) m2) = Some b)). - * eapply eval_condition0_inj. - constructor. - assumption. - * rewrite Hcond'. constructor. - + destruct (eval_condition0 cond _ m1) eqn:Hcond; trivial. - assert (Hcond' : ((eval_condition0 cond (Vlong i1) m2) = Some b)). - - trivial. - exploit eval_condition0_inj; eauto. - exploit eval_condition0_inj; eauto. - destruct v; trivial. - destruct v0; trivial. - destruct v'; 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 *) - inv H3; simpl; try constructor. inv H4; simpl; try constructor. -- cgit From b3ab0cbe385932f8389049d01f4989829725495e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 4 Apr 2019 14:12:59 +0200 Subject: Erreur idiote dans les latences ? --- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 762c67fc..6bb1c6b8 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -634,6 +634,7 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" and read = ref [] 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 @@ -641,7 +642,7 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" and waw = get_accesses i.write_locs !written and war = get_accesses i.write_locs !read in begin - List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = i.latency} :: !constraints) (raw @ waw); + 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 *) if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); @@ -649,7 +650,6 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" read := read_accesses @ !read; count := !count + 1 end - and instr_infos = instruction_infos bb in (List.iter step instr_infos; !constraints) (** -- cgit From b4ed42a385a4560c82d9ffa234fd00608f431583 Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 4 Apr 2019 15:01:58 +0200 Subject: dist_end_block_code_simu_mid_block proof --- mppa_k1c/Machblockgenproof.v | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 0ca23a36..267cbebb 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -307,11 +307,18 @@ Proof. unfold add_label, size; simpl; omega. Qed. +Lemma size_add_basic bi bh: header bh = nil -> size (add_basic bi bh) = size bh + 1. +Proof. + intro H. unfold add_basic, size; rewrite H; simpl. omega. +Qed. + + Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. Proof. destruct i; auto. Qed. + Lemma dist_end_block_code_simu_mid_block i c: dist_end_block_code (i::c) <> 0 -> (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). @@ -324,7 +331,11 @@ Proof. - rewrite size_add_label; subst_is_trans_code H. omega. -Admitted. (* A FINIR *) + - rewrite size_add_basic; auto. + subst_is_trans_code H. + omega. +Qed. + Local Hint Resolve dist_end_block_code_simu_mid_block. -- cgit From 8b8969b36f9506ea5f32a3ff5ebab4860878dcbd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 4 Apr 2019 15:41:28 +0200 Subject: Refactorisation de forward_simu_par_control --- mppa_k1c/Asmblockdeps.v | 204 +++++++++++++++--------------------------------- 1 file changed, 63 insertions(+), 141 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9180eabb..45f1fffa 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1896,116 +1896,76 @@ Proof. eapply IHbdy; eauto. Qed. -Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': +Theorem forward_simu_par_control_gen ge fn rsr rsw mr mw sr sw sz ex: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> - exists s', - inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' - /\ match_states (State rs' m') s'. + match_outcome (parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. - intros GENV MSR MSW H0. - simpl in *. + intros GENV MSR MSW. + simpl in *. inv MSR. inv MSW. destruct ex. - - destruct c; destruct i; try discriminate. - all: try (inv H0; inv MSR; inv MSW; eexists; split; [| split]; [simpl; rewrite (H0 PC); reflexivity | Simpl | intros rr; destruct rr; unfold par_nextblock; Simpl]). + - destruct c; destruct i; try discriminate; simpl. + all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold par_nextblock; Simpl). (* Pjumptable *) - + simpl in H0. destruct (par_nextblock _ _ _) eqn:PNEXT; try discriminate. - destruct (list_nth_z _ _) eqn:LISTS; try discriminate. unfold par_goto_label in H0. - destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ rsr PC) eqn:NB; try discriminate. inv H0. - inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). Simpl. rewrite (H0 r). unfold par_nextblock in PNEXT. rewrite Pregmap.gso in PNEXT; try discriminate. rewrite PNEXT. - rewrite LISTS. unfold goto_label_deps. rewrite LPOS. unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - destruct (preg_eq g GPR62). rewrite e. Simpl. - destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. + + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold par_nextblock. Simpl. + destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. + unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold par_nextblock; Simpl. + destruct (preg_eq g GPR62). rewrite e. Simpl. + destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. + (* Pj_l *) - + simpl in H0. unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ _) eqn:NB; try discriminate. inv H0. - inv MSR; inv MSW. - eexists; split; try split. - * simpl. rewrite (H0 PC). unfold goto_label_deps. rewrite LPOS. Simpl. - unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. + + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. + unfold par_nextblock. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold par_nextblock; Simpl. + (* Pcb *) - + simpl in H0. destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold par_eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. - inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. - unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - ++ unfold par_eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. - inv H0; inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. - unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - (* Pcbu *) - + simpl in H0. destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold par_eval_branch in H0. destruct (Val_cmpu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. - inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. - unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - ++ unfold par_eval_branch in H0. destruct (Val_cmplu_bool _ _ _) eqn:VALCMP; try discriminate. destruct b. - +++ unfold par_goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (par_nextblock _ _ PC) eqn:NB; try discriminate. - inv H0; inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. - unfold par_nextblock in NB. rewrite Pregmap.gss in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - +++ inv H0. inv MSR; inv MSW. eexists; split; try split. - * simpl. rewrite (H0 PC). - rewrite CFB. Simpl. rewrite (H0 r). - unfold eval_branch_deps. unfold par_nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; unfold par_nextblock; Simpl. - - simpl in *. inv MSR. inv MSW. inv H0. eexists. split. - rewrite (H1 PC). simpl. reflexivity. - split. Simpl. - intros rr. destruct rr; unfold par_nextblock; Simpl. + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold par_nextblock. Simpl. destruct i. + ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + + (* Pcbu *) + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold par_nextblock. Simpl. destruct i. + ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + + - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. + intros rr; destruct rr; unfold par_nextblock; Simpl. +Qed. + +Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> + exists s', + inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' + /\ match_states (State rs' m') s'. +Proof. + intros. exploit forward_simu_par_control_gen. 3: eapply H1. 2: eapply H0. all: eauto. + intros. erewrite H2 in H3. inv H3. eexists. + eapply H4. Qed. Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: @@ -2015,46 +1975,8 @@ Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Stuck -> inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Proof. - intros GENV MSR MSW H0. inv MSR; inv MSW. destruct ex as [ctl|]; try discriminate. - destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). -(* Pbuiltin *) - - simpl in *. rewrite (H1 PC). reflexivity. -(* Pjumptable *) - - simpl in *. rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. - destruct (rsr r); auto. destruct (list_nth_z _ _); auto. unfold par_goto_label in H0. unfold goto_label_deps. - destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); try discriminate; auto. -(* Pj_l *) - - simpl in *. rewrite (H1 PC). unfold goto_label_deps. unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. simpl in *. unfold par_nextblock in H0. rewrite Pregmap.gss in H0. - destruct (Val.offset_ptr _ _); try discriminate; auto. -(* Pcb *) - - simpl in *. destruct (cmp_for_btest bt). destruct i. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. - destruct (Val.cmp_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. - + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. - destruct (Val.cmpl_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. - + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. -(* Pcbu *) - - simpl in *. destruct (cmpu_for_btest bt). destruct i. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. - destruct (Val_cmpu_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. - + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - rewrite (H1 PC). Simpl. rewrite (H1 r). unfold par_nextblock in H0. rewrite Pregmap.gso in H0; try discriminate. - destruct (Val_cmplu_bool _ _ _); auto. destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. rewrite Pregmap.gss in H0. destruct (Val.offset_ptr _ _); auto. discriminate. - + rewrite (H1 PC). Simpl. rewrite (H1 r). reflexivity. + intros. exploit forward_simu_par_control_gen. 3: eapply H1. 2: eapply H0. all: eauto. + intros. erewrite H2 in H3. inv H3. unfold trans_pcincr. unfold inst_prun. unfold exp_eval. unfold op_eval. destruct (control_eval _ _ _); auto. Qed. Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). -- cgit From 7171888446d3d4b47765cc21d982eb2045cd00cd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 16:27:52 +0200 Subject: some more progress on select --- mppa_k1c/Op.v | 15 ++-------- mppa_k1c/SelectOp.vp | 4 +-- mppa_k1c/SelectOpproof.v | 53 ++++++++++++++++++------------------ mppa_k1c/ValueAOp.v | 71 +++++++++++++++++++++++++++++++++++------------- 4 files changed, 84 insertions(+), 59 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c3ea4baf..e619b2f5 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -283,18 +283,9 @@ Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := end. Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0 with - | Vint i0 => - match v1 with - | Vint i1 => - match (eval_condition0 cond vselect m) with - | Some bval => - Vint (if bval then i1 else i0) - | None => Vundef - end - | _ => Vundef - end - | _ => Vundef + 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_selectl (v0 : val) (v1 : val) (vselect : val) : val := diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6d61e674..31e81093 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -283,7 +283,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then Eop Oselect (v0:::v1:::y0:::Enil) + then Eop (Oselect (Ccomp0 Cne)) (v0:::v1:::y0:::Enil) else Eop Oor (e1:::e2:::Enil) | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Ceq zero0)) (y0:::Enil)):::Enil)):::v0:::Enil)), @@ -292,7 +292,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then Eop Oselect (v0:::v1:::y0:::Enil) + then Eop (Oselect (Ccompu0 Cne)) (v0:::v1:::y0:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 20ba74a1..4af5ccfa 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -582,22 +582,22 @@ Proof. inv H2. inv H5. replace v8 with v4 in * by congruence. rename v4 into vselect. - destruct vselect; simpl; trivial. - rewrite (Val.and_commut _ v5). - destruct v5; simpl; trivial. - rewrite (Val.and_commut _ v9). - rewrite Val.or_commut. - destruct v9; simpl; trivial. - rewrite int_eq_commut. - destruct (Int.eq i1 Int.zero); simpl. - + rewrite Int.and_zero. - rewrite Int.or_commut. - rewrite Int.or_zero. + 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.and_mone. - rewrite Int.neg_zero. + + 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 *) @@ -620,22 +620,23 @@ Proof. inv H2. inv H5. replace v8 with v4 in * by congruence. rename v4 into vselect. - destruct vselect; simpl; trivial. - rewrite (Val.and_commut _ v5). - destruct v5; simpl; trivial. - rewrite (Val.and_commut _ v9). - rewrite Val.or_commut. - destruct v9; simpl; trivial. - rewrite int_eq_commut. - destruct (Int.eq i1 Int.zero); simpl. - + rewrite Int.and_zero. - rewrite Int.or_commut. - rewrite Int.or_zero. + 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.and_mone. - rewrite Int.neg_zero. + + 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. - apply DEFAULT. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 122249a4..af685a5e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -42,16 +42,36 @@ Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := | _, _ => Vbot end. -Definition select (v0 v1 vselect : aval) : aval := - match vselect with - | I iselect => - if Int.eq Int.zero iselect - then binop_int (fun x0 x1 => x0) v0 v1 - else binop_int (fun x0 x1 => x1) v0 v1 +Definition eval_static_condition0 (cond : condition0) (v : aval) : abool := + match cond with + | Ccomp0 c => cmp_bool c v (I Int.zero) + | Ccompu0 c => cmpu_bool c v (I Int.zero) + | Ccompl0 c => cmpl_bool c v (L Int64.zero) + | 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 selectl (v0 v1 vselect : aval) : aval := +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_static_selectl (v0 v1 vselect : aval) : aval := match vselect with | I iselect => if Int.eq Int.zero iselect @@ -60,7 +80,7 @@ Definition selectl (v0 v1 vselect : aval) : aval := | _ => Vtop end. -Definition selectf (v0 v1 vselect : aval) : aval := +Definition eval_static_selectf (v0 v1 vselect : aval) : aval := match vselect with | I iselect => if Int.eq Int.zero iselect @@ -69,7 +89,7 @@ Definition selectf (v0 v1 vselect : aval) : aval := | _ => Vtop end. -Definition selectfs (v0 v1 vselect : aval) : aval := +Definition eval_static_selectfs (v0 v1 vselect : aval) : aval := match vselect with | I iselect => if Int.eq Int.zero iselect @@ -202,10 +222,10 @@ 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, v0::v1::vselect::nil => select v0 v1 vselect - | Oselectl, v0::v1::vselect::nil => selectl v0 v1 vselect - | Oselectf, v0::v1::vselect::nil => selectf v0 v1 vselect - | Oselectfs, v0::v1::vselect::nil => selectfs v0 v1 vselect + | (Oselect cond), v0::v1::vselect::nil => eval_static_select cond v0 v1 vselect + | Oselectl, v0::v1::vselect::nil => eval_static_selectl v0 v1 vselect + | Oselectf, v0::v1::vselect::nil => eval_static_selectf v0 v1 vselect + | Oselectfs, v0::v1::vselect::nil => eval_static_selectfs v0 v1 vselect | _, _ => Vbot end. @@ -231,6 +251,15 @@ Proof. destruct cond; auto with va. Qed. +Theorem eval_static_condition0_sound: + forall cond varg m aarg, + vmatch bc varg aarg -> + cmatch (eval_condition0 cond varg m) (eval_static_condition0 cond aarg). +Proof. + intros until aarg; intro VM. + destruct cond; simpl; eauto with va. +Qed. + Lemma symbol_address_sound: forall id ofs, vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). @@ -276,18 +305,22 @@ Theorem eval_static_operation_sound: list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. - unfold eval_operation, eval_static_operation; intros; + unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; 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 *) - - inv H2; simpl; try constructor. - + destruct (Int.eq _ _); apply binop_int_sound; trivial. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + - 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 *) - inv H2; simpl; try constructor. + destruct (Int.eq _ _); apply binop_long_sound; trivial. -- cgit From 1dd304f6de9839f471a4aa78dcf08422d820fa18 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 4 Apr 2019 17:34:58 +0200 Subject: refactorized forward_simu_control --- mppa_k1c/Asmblockdeps.v | 174 +++++++++++++++++++----------------------------- 1 file changed, 67 insertions(+), 107 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 45f1fffa..a5880128 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -905,117 +905,79 @@ Proof. * eassumption. Qed. -Lemma forward_simu_control: - forall ge fn ex b rs m rs2 m2 s, +Theorem forward_simu_control_gen ge fn ex b rs m s: Ge = Genv ge fn -> - exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> match_states (State rs m) s -> - exists s', - exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = Some s' - /\ match_states (State rs2 m2) s'. + match_outcome (exec_control ge fn ex (nextblock b rs) m) (exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s). Proof. - intros. destruct ex. - - simpl in *. inv H1. destruct c; destruct i; try discriminate. - all: try (inv H0; eexists; split; try split; [ simpl control_eval; pose (H3 PC); simpl in e; rewrite e; reflexivity | Simpl | intros rr; destruct rr; Simpl]). + intros. destruct ex; simpl; inv H0. + - destruct c; destruct i; simpl; rewrite (H2 PC); auto. + all: try (eexists; split; try split; Simpl; intros rr; destruct rr; unfold nextblock; Simpl). + (* Pjumptable *) - + unfold goto_label in *. - repeat (rewrite Pregmap.gso in H0; try discriminate). - destruct (nextblock _ _ _) eqn:NB; try discriminate. - destruct (list_nth_z _ _) eqn:LI; try discriminate. - destruct (label_pos _ _ _) eqn:LPOS; try discriminate. - destruct (nextblock b rs PC) eqn:MB2; try discriminate. inv H0. - eexists; split; try split. - * simpl control_eval. rewrite (H3 PC). simpl. Simpl. - rewrite H3. unfold nextblock in NB. rewrite Pregmap.gso in NB; try discriminate. rewrite NB. - rewrite LI. unfold goto_label_deps. rewrite LPOS. - unfold nextblock in MB2. rewrite Pregmap.gss in MB2. rewrite MB2. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (preg_eq GPR62 g); Simpl. rewrite e. Simpl. - destruct (preg_eq GPR63 g); Simpl. rewrite e. Simpl. + + Simpl. rewrite (H2 r). destruct (rs r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. + unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + destruct (preg_eq GPR62 g). rewrite e. Simpl. + destruct (preg_eq GPR63 g). rewrite e. Simpl. Simpl. + (* Pj_l *) - + unfold goto_label in H0. - destruct (label_pos _ _ _) eqn:LPOS; try discriminate. - destruct (nextblock _ _ _) eqn:NB; try discriminate. inv H0. - eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. - rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. + + Simpl. unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. + unfold nextblock. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + (* Pcb *) - + destruct (cmp_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold eval_branch in H0. destruct (Val.cmp_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. - +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. - inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - ++ unfold eval_branch in H0. destruct (Val.cmpl_bool _ _ _) eqn:VALCMP; try discriminate. destruct b0. - +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. - inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. + + Simpl. destruct (cmp_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. + ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b0. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b0. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + (* Pcbu *) - + destruct (cmpu_for_btest _) eqn:CFB. destruct o; try discriminate. destruct i. - ++ unfold eval_branch in H0. destruct (Val_cmpu_bool _ _) eqn:VALCMP; try discriminate. destruct b0. - +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. - inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - ++ unfold eval_branch in H0. destruct (Val_cmplu_bool _ _) eqn:VALCMP; try discriminate. destruct b0. - +++ unfold goto_label in H0. destruct (label_pos _ _ _) eqn:LPOS; try discriminate. destruct (nextblock b rs PC) eqn:NB; try discriminate. - inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - unfold goto_label_deps. rewrite LPOS. rewrite nextblock_pc in NB. rewrite NB. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - +++ inv H0. eexists; split; try split. - * simpl control_eval. pose (H3 PC); simpl in e; rewrite e. simpl. - rewrite CFB. Simpl. pose (H3 r). simpl in e0. rewrite e0. - unfold eval_branch_deps. unfold nextblock in VALCMP. rewrite Pregmap.gso in VALCMP; try discriminate. rewrite VALCMP. - reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - - simpl in *. inv H1. inv H0. eexists. split. - pose (H3 PC). simpl in e. rewrite e. simpl. reflexivity. - split. Simpl. - intros. unfold nextblock. destruct r; Simpl. -Qed. + + Simpl. destruct (cmpu_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. + ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b0. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b0. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + + - simpl. rewrite (H2 PC). eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +Qed. + +Lemma forward_simu_control ge fn ex b rs m rs2 m2 s: + Ge = Genv ge fn -> + exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> + match_states (State rs m) s -> + exists s', + exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = Some s' + /\ match_states (State rs2 m2) s'. +Proof. + intros. exploit (forward_simu_control_gen); eauto. intros. + rewrite H0 in H2. inv H2. eexists. eapply H3. +Qed. + +Lemma forward_simu_control_stuck: + forall ge fn rs m s ex b, + Ge = Genv ge fn -> + match_states (State rs m) s -> + exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = None -> + exec_control ge fn ex (nextblock b rs) m = Stuck. +Proof. + intros. exploit (forward_simu_control_gen); eauto. intros. + rewrite H1 in H2. destruct (exec_control _ _ _ _ _); auto. inv H2. inv H3. discriminate. +Qed. Theorem forward_simu: forall rs1 m1 rs2 m2 s1' b ge fn, @@ -1181,9 +1143,7 @@ Proof. - right. repeat eexists. exploit exec_body_next_exec; eauto. intros (s' & EXECBK' & MS'). unfold trans_block in EXECBK. rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. - exploit exec_trans_pcincr_exec; eauto. intros (s'' & EXECINCR' & MS''). - rewrite EXECINCR' in EXECBK. clear EXECINCR' MS'. - eapply exec_exit_none; eauto. + eapply forward_simu_control_stuck; eauto. - left. reflexivity. Qed. -- cgit From 8610699d59dab908ec5954733753008ecfb871ff Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 4 Apr 2019 17:59:06 +0200 Subject: is_header, is_body, is_exit --- mppa_k1c/Machblockgenproof.v | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 267cbebb..792fcc90 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -343,18 +343,30 @@ Lemma size_nonzero c b bl: is_trans_code c (b :: bl) -> size b <> 0. Proof. intros H; inversion H; subst. -Admitted. (* A FINIR *) + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; omega. + - rewrite size_add_basic; auto; omega. +Qed. (* TODO: définir les predicats inductifs suivants de façon à prouver le lemme [is_trans_code_decompose] ci-dessous *) + Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := - . (* A FAIRE *) + | header_empty : is_header nil nil nil + | header_not_label i c: forall l, i <> Mlabel l -> is_header nil (i::c) c + | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 + . Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := - . (* A FAIRE *) + | body_empty : is_body nil nil nil + | body_not_bi i c: forall bi, (trans_inst i) <> (MB_basic bi) -> is_body nil (i::c) c + | body_is_bi i lbi c0 c1: forall bi, (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 + . Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := - . (* A FAIRE *) + | exit_not_cfi i c : forall cfi, (trans_inst i) <> MB_cfi cfi -> is_exit None (i::c) c + | exit_is_cfi i c : forall cfi, (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c + . Lemma trans_code_decompose c bc: is_trans_code c bc -> forall b blc, bc=(b::blc) -> -- cgit From 4b018d72e7494cc3eb8b0385a78b3c888aebfd66 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 4 Apr 2019 18:17:57 +0200 Subject: Refactorisation de forward_simu_basic --- mppa_k1c/Asmblockdeps.v | 157 +++++++++++++++++------------------------------- 1 file changed, 55 insertions(+), 102 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a5880128..92630772 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -810,80 +810,78 @@ Proof. destruct (ireg_eq g rd); subst; Simpl. Qed. -Lemma forward_simu_basic: - forall ge fn b rs m rs' m' s, - exec_basic_instr ge b rs m = Next rs' m' -> +Theorem forward_simu_basic_gen ge fn b rs m s: match_states (State rs m) s -> - exists s', - inst_run (Genv ge fn) (trans_basic b) s s = Some s' - /\ match_states (State rs' m') s'. + match_outcome (exec_basic_instr ge b rs m) (inst_run (Genv ge fn) (trans_basic b) s s). Proof. - intros. destruct b. + intros. destruct b; inversion H; simpl. (* Arith *) - - simpl in H. inv H. simpl inst_run. eapply trans_arith_correct; eauto. + - eapply trans_arith_correct; eauto. (* Load *) - - simpl in H. destruct i. + - destruct i. (* Load Offset *) - + destruct i. all: - unfold exec_load_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; [ - simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); simpl in MEML; rewrite MEML; reflexivity - | Simpl - | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. - (* Load Reg *) - + destruct i. all: - unfold exec_load_reg in H; destruct (Mem.loadv _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; - [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); unfold exec_load_deps_reg; simpl in MEML; rewrite MEML; reflexivity - | Simpl - | intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl ]. + + destruct i; simpl; + unfold exec_load_offset; rewrite (H1 ra); rewrite H0; + destruct (eval_offset _ _); simpl; auto; destruct (Mem.loadv _ _); simpl; auto; + eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + + destruct i; simpl; + unfold exec_load_reg; rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_load_deps_reg; + destruct (Mem.loadv _ _); simpl; auto; + eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Store *) - - simpl in H. destruct i. + - destruct i. (* Store Offset *) - + destruct i. all: - unfold exec_store_offset in H; destruct (eval_offset _ _) eqn:EVALOFF; try discriminate; - destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; - [ simpl; rewrite EVALOFF; rewrite H; rewrite (H1 ra); rewrite (H1 rs0); simpl in MEML; rewrite MEML; reflexivity - | Simpl - | intros rr; destruct rr; Simpl ]. - (* Store Reg *) - + destruct i. all: - unfold exec_store_reg in H; - destruct (Mem.storev _ _ _ _) eqn:MEML; try discriminate; inv H; inv H0; - eexists; split; try split; - [ simpl; rewrite H; rewrite (H1 rofs); rewrite (H1 ra); rewrite (H1 rs0); unfold exec_store_deps_reg; - simpl in MEML; rewrite MEML; reflexivity - | Simpl - | intros rr; destruct rr; Simpl ]. + + destruct i; simpl; + rewrite (H1 rs0); rewrite (H1 ra); rewrite H0; unfold exec_store_offset; destruct (eval_offset _ _); simpl; auto; + destruct (Mem.storev _ _ _ _); simpl; auto; + eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + + + destruct i; simpl; + rewrite (H1 rs0); rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_store_reg; unfold exec_store_deps_reg; + destruct (Mem.storev _ _ _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. (* Allocframe *) - - simpl in H. destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS; try discriminate. - inv H. inv H0. eexists. split; try split. - * simpl. Simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite MEMAL. rewrite MEMS. Simpl. - rewrite H. rewrite MEMAL. rewrite MEMS. reflexivity. + - Simpl. rewrite (H1 SP). rewrite H0. destruct (Mem.alloc _ _ _) eqn:ALLOC; simpl; auto. destruct (Mem.store _ _ _ _) eqn:STORE; simpl; auto. + eexists; split; try split. + * Simpl. rewrite H0. rewrite ALLOC. rewrite STORE. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. + (* Freeframe *) - - simpl in H. destruct (Mem.loadv _ _ _) eqn:MLOAD; try discriminate. destruct (rs GPR12) eqn:SPeq; try discriminate. - destruct (Mem.free _ _ _ _) eqn:MFREE; try discriminate. inv H. inv H0. - eexists. split; try split. - * simpl. pose (H1 GPR12); simpl in e; rewrite e. rewrite H. rewrite SPeq. rewrite MLOAD. rewrite MFREE. - Simpl. rewrite e. rewrite SPeq. rewrite MLOAD. rewrite MFREE. reflexivity. + - rewrite (H1 SP). rewrite H0. destruct (Mem.loadv _ _ _) eqn:LOAD; simpl; auto. destruct (rs GPR12) eqn:SPeq; simpl; auto. + destruct (Mem.free _ _ _ _) eqn:FREE; simpl; auto. Simpl. rewrite (H1 SP). eexists; split; try split. + * rewrite SPeq. rewrite LOAD. rewrite FREE. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. + (* Pget *) - - simpl in H. destruct rs0 eqn:rs0eq; try discriminate. inv H. inv H0. - eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. + - destruct rs0; simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. + (* Pset *) - - simpl in H. destruct rd eqn:rdeq; try discriminate. inv H. inv H0. - eexists. split; try split. Simpl. intros rr; destruct rr; Simpl. + - destruct rd; simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + (* Pnop *) - - simpl in H. inv H. inv H0. eexists. split; try split. assumption. assumption. + - eexists; split; try split. assumption. assumption. +Qed. + +Lemma forward_simu_basic ge fn b rs m rs' m' s: + exec_basic_instr ge b rs m = Next rs' m' -> + match_states (State rs m) s -> + exists s', + inst_run (Genv ge fn) (trans_basic b) s s = Some s' + /\ match_states (State rs' m') s'. +Proof. + intros. exploit forward_simu_basic_gen; eauto. intros. rewrite H in H1. inv H1. eexists. eassumption. +Qed. + +Lemma forward_simu_basic_instr_stuck i ge fn rs m s: + Ge = Genv ge fn -> + exec_basic_instr ge i rs m = Stuck -> + match_states (State rs m) s -> + exec Ge [trans_basic i] s = None. +Proof. + intros. exploit forward_simu_basic_gen; eauto. intros. rewrite H0 in H2. inv H2. unfold exec. unfold run. rewrite H4. reflexivity. Qed. Lemma forward_simu_body: @@ -1147,51 +1145,6 @@ Proof. - left. reflexivity. Qed. -Lemma forward_simu_basic_instr_stuck: - forall i ge fn rs m s, - Ge = Genv ge fn -> - exec_basic_instr ge i rs m = Stuck -> - match_states (State rs m) s -> - exec Ge [trans_basic i] s = None. -Proof. - intros. inv H1. unfold exec_basic_instr in H0. destruct i; try discriminate. -(* PLoad *) - - destruct i. - (* Load Offset *) - + destruct i. all: - simpl; rewrite H2; rewrite (H3 ra); unfold exec_load_offset in H0; destruct (eval_offset _ _); auto; - simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. - (* Load Reg *) - + destruct i. all: - simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); unfold exec_load_reg in H0; unfold exec_load_deps_reg; - destruct (rs rofs); auto; simpl in H0; destruct (Mem.loadv _ _ _); auto; discriminate. - -(* PStore *) - - destruct i. - (* Store Offset *) - + destruct i. all: - simpl; rewrite H2; rewrite (H3 ra); rewrite (H3 rs0); unfold exec_store_offset in H0; destruct (eval_offset _ _); auto; - simpl in H0; destruct (Mem.storev _ _ _); auto; discriminate. - (* Store Reg *) - + destruct i. all: - simpl; rewrite H2; rewrite (H3 rofs); rewrite (H3 ra); rewrite (H3 rs0); simpl in H0; unfold exec_store_reg in H0; - unfold exec_store_deps_reg; destruct (rs rofs); auto; - destruct (Mem.storev _ _ _ _); auto; discriminate. - -(* Pallocframe *) - - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. destruct (Mem.alloc _ _ _). simpl in H0. - destruct (Mem.store _ _ _ _); try discriminate. reflexivity. -(* Pfreeframe *) - - simpl. Simpl. pose (H3 SP); simpl in e; rewrite e; clear e. rewrite H2. - destruct (Mem.loadv _ _ _); auto. destruct (rs GPR12); auto. destruct (Mem.free _ _ _ _); auto. - discriminate. -(* Pget *) - - simpl. destruct rs0; subst; try discriminate. - all: simpl; auto. - - simpl. destruct rd; subst; try discriminate. - all: simpl; auto. -Qed. - Lemma forward_simu_body_stuck: forall bdy ge fn rs m s, Ge = Genv ge fn -> -- cgit From 7946ed0e9130e164c39e137115419ea0ed158c9f Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 4 Apr 2019 19:37:09 +0200 Subject: relecture is_header, is_body, is_exit + pattern de preuve trans_code_decompose --- mppa_k1c/Machblockgenproof.v | 45 ++++++++++++++++++++++++++++---------------- 1 file changed, 29 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 792fcc90..07ec9d08 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -348,39 +348,52 @@ Proof. - rewrite size_add_basic; auto; omega. Qed. -(* TODO: définir les predicats inductifs suivants de façon à prouver le lemme [is_trans_code_decompose] ci-dessous *) - - Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := | header_empty : is_header nil nil nil - | header_not_label i c: forall l, i <> Mlabel l -> is_header nil (i::c) c + | header_not_label i c: (forall l, i <> Mlabel l) -> is_header nil (i::c) (i::c) | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 . Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := | body_empty : is_body nil nil nil - | body_not_bi i c: forall bi, (trans_inst i) <> (MB_basic bi) -> is_body nil (i::c) c - | body_is_bi i lbi c0 c1: forall bi, (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 + | body_not_bi i c: (forall bi, (trans_inst i) <> (MB_basic bi)) -> is_body nil (i::c) (i::c) + | body_is_bi i lbi c0 c1 bi: (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 . Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := - | exit_not_cfi i c : forall cfi, (trans_inst i) <> MB_cfi cfi -> is_exit None (i::c) c - | exit_is_cfi i c : forall cfi, (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c + | exit_empty: is_exit None nil nil + | exit_not_cfi i c: (forall cfi, (trans_inst i) <> MB_cfi cfi) -> is_exit None (i::c) (i::c) + | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c . -Lemma trans_code_decompose c bc: - is_trans_code c bc -> forall b blc, bc=(b::blc) -> - exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 blc. +Lemma trans_code_decompose c: forall b bl, + is_trans_code c (b::bl) -> + exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. Proof. - induction 1; intros b blc X; inversion X; subst; clear X. -Admitted. + induction c as [|i c]. + { (* nil => absurd *) intros b bl H; inversion H. } + intros b bl H; remember (trans_inst i) as ti. + destruct ti as [lbl|bi|cfi]; + inversion H as [|d0 d1 d2 H0 H1| |]; subst; + try (rewrite <- Heqti in * |- *); simpl; + try congruence. + + (* label at end block *) + inversion H1; subst. inversion H0; subst. + assert (X:i=Mlabel lbl). { destruct i; simpl in Heqti; congruence. } + subst. repeat econstructor; eauto. + + (* label at mid block *) + exploit IHc; eauto. + intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). + repeat econstructor; eauto. + + (* basic at end block *) +Admitted. (* A FINIR *) Lemma step_simu_header st f sp rs m s c h c' t: is_header h c c' -> starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. Proof. - induction 1. (* A FINIR *) + induction 1; simpl. (* A FINIR *) Admitted. (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? induction c as [ | i c]; simpl; intros h c' t H. @@ -580,7 +593,7 @@ Proof. exploit step_simu_exit_step; eauto. clear H3; intros (s2' & H3 & H4). eapply ex_intro; intuition eauto. - (* VIELLE PREUVE: eapply exec_bblock; eauto. *) + eapply exec_bblock; eauto. + (* Callstate *) intros t s1' H; inversion_clear H. eapply ex_intro; constructor 1; eauto. @@ -602,7 +615,7 @@ Proof. inversion H1; subst; clear H1. inversion_clear H0; simpl. eapply exec_return. -Admitted. (* A FIXER *) +Qed. Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). -- cgit From 7a69f306599498055a1420b16058572e3cbb0fc7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 19:54:25 +0200 Subject: select_sound --- mppa_k1c/NeedOp.v | 110 +++++++++++++++++++++++++++++++++++++++++----------- mppa_k1c/Op.v | 15 +++++++ mppa_k1c/ValueAOp.v | 15 ------- 3 files changed, 102 insertions(+), 38 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index ee3c4e27..375a9cfe 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -117,7 +117,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) + | Oselect _ | Oselectl | Oselectf | Oselectfs => op3 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -146,19 +146,77 @@ Section SOUNDNESS. Variable ge: genv. Variable sp: block. -Variables m m': mem. -Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. +Variables m1 m2: mem. +Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p. Lemma needs_of_condition_sound: forall cond args b args', - eval_condition cond args m = Some b -> + eval_condition cond args m1 = Some b -> vagree_list args args' (needs_of_condition cond) -> - eval_condition cond args' m' = Some b. + eval_condition cond args' m2 = Some b. Proof. intros. unfold needs_of_condition in H0. eapply default_needs_of_condition_sound; eauto. Qed. +Let valid_pointer_inj: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. + rewrite Mem.valid_pointer_nonempty_perm in *. eauto. +Qed. + +Let weak_valid_pointer_inj: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. + rewrite Mem.weak_valid_pointer_spec in *. + rewrite ! Mem.valid_pointer_nonempty_perm in *. + destruct H0; [left|right]; eauto. +Qed. + +Let weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + unfold inject_id; intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Let valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + inject_id b1 = Some (b1', delta1) -> + inject_id b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + unfold inject_id; intros. left; congruence. +Qed. + +Lemma needs_of_condition0_sound: + forall cond arg1 b arg2, + eval_condition0 cond arg1 m1 = Some b -> + vagree arg1 arg2 All -> + eval_condition0 cond arg2 m2 = Some b. +Proof. + intros until arg2. + intros Hcond Hagree. + Check eval_condition_inj. + Check default_needs_of_condition_sound. + apply eval_condition0_inj with (f := inject_id) (m1 := m1) (v1 := arg1); simpl; auto. + apply val_inject_lessdef. apply lessdef_vagree. assumption. +Qed. + Lemma addl_sound: forall v1 w1 v2 w2 x, vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> @@ -186,26 +244,32 @@ Proof. inv H. inv H0. trivial. Qed. - + Lemma select_sound: - forall 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 v0 v1 v2) (eval_select w0 w1 w2) x. + forall cond v0 w0 v1 w1 v2 w2, + vagree v0 w0 All -> + vagree v1 w1 All -> + vagree v2 w2 All -> + vagree (eval_select cond v0 v1 v2 m1) (eval_select cond w0 w1 w2 m2) All. Proof. - unfold default; intros. - destruct x; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - inv H. inv H0. inv H1. simpl. - constructor. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - inv H. inv H0. inv H1. simpl. - constructor. + intros. + 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 *. + - 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. + - simpl. constructor. Qed. Lemma selectl_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index e619b2f5..51d70693 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -288,6 +288,21 @@ Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) | _,_,_ => 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 (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index af685a5e..e791cc40 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -56,21 +56,6 @@ Definition eval_static_select (cond : condition0) (v0 v1 vselect : aval) : aval | _ => Vtop 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_static_selectl (v0 v1 vselect : aval) : aval := match vselect with | I iselect => -- cgit From 60ff9fd4c1387bf46fa702d564cfbba44a4f83ea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 20:28:03 +0200 Subject: progress on Oselect --- mppa_k1c/NeedOp.v | 54 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 375a9cfe..d385ebac 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -211,8 +211,6 @@ Lemma needs_of_condition0_sound: Proof. intros until arg2. intros Hcond Hagree. - Check eval_condition_inj. - Check default_needs_of_condition_sound. apply eval_condition0_inj with (f := inject_id) (m1 := m1) (v1 := arg1); simpl; auto. apply val_inject_lessdef. apply lessdef_vagree. assumption. Qed. @@ -246,21 +244,40 @@ Proof. Qed. Lemma select_sound: - forall cond v0 w0 v1 w1 v2 w2, - vagree v0 w0 All -> - vagree v1 w1 All -> - vagree v2 w2 All -> - vagree (eval_select cond v0 v1 v2 m1) (eval_select cond w0 w1 w2 m2) All. + 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. - 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 *. - - destruct b. + 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. @@ -269,7 +286,6 @@ Proof. inv H; trivial. destruct w0; trivial. inv H0; trivial. - - simpl. constructor. Qed. Lemma selectl_sound: @@ -336,11 +352,11 @@ Qed. Lemma needs_of_operation_sound: forall op args v nv args', - eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> vagree_list args args' (needs_of_operation op nv) -> nv <> Nothing -> exists v', - eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' + eval_operation ge (Vptr sp Ptrofs.zero) op args' m2 = Some v' /\ vagree v v' nv. Proof. unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); @@ -394,7 +410,7 @@ Qed. Lemma operation_is_redundant_sound: forall op nv arg1 args v arg1' args', operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m1 = Some v -> vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> vagree v arg1' nv. Proof. -- cgit From 71c38724bee43fe1a2ce67ee51f09478cd167929 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 21:31:36 +0200 Subject: Oselect --- mppa_k1c/Asmblockgen.v | 12 +++++++++++- mppa_k1c/Asmblockgenproof1.v | 9 +++++---- 2 files changed, 16 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ad01ff89..722c4acc 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -729,7 +729,17 @@ Definition transl_op do rd <- ireg_of res; transl_cond_op cmp rd args k - | Oselect, a0 :: a1 :: aS :: nil + | Oselect 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) + | _ => Error (msg "Asmblockgen Oselect") + end) + | Oselectl, a0 :: a1 :: aS :: nil | Oselectf, a0 :: a1 :: aS :: nil | Oselectfs, a0 :: a1 :: aS :: nil => diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 698d64d6..e8e04019 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1638,17 +1638,18 @@ Opaque Int.eq. 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; injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in *. econstructor; split. + + eapply exec_straight_one. simpl; reflexivity. + split. * unfold eval_select. - destruct (rs x1) eqn:eqX1; try constructor. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. - simpl. - rewrite int_eq_comm. - destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; constructor. + destruct c0 in *; simpl; + destruct (Val.cmp_bool _ _); simpl; try constructor; + destruct b; simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. - (* Oselectl *) -- cgit From e08d244a18870131820814880685504f0ea467e6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 21:40:04 +0200 Subject: more on select --- mppa_k1c/SelectOp.vp | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 31e81093..10c91bba 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -61,6 +61,11 @@ Section SELECT. Context {hf: helper_functions}. +(** Ternary operator *) +Definition select o0 o1 oselect := + Eop (Oselect (Ccomp0 Ceq)) + (o0:::o1:::oselect:::Enil). + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := -- cgit From a1c645892fda697675605f446f86fef90d43971d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 21:48:12 +0200 Subject: ternary ops work on (unsigned/signed) int with test on signed int --- mppa_k1c/SelectOp.vp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 10c91bba..906d6791 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -63,7 +63,7 @@ Context {hf: helper_functions}. (** Ternary operator *) Definition select o0 o1 oselect := - Eop (Oselect (Ccomp0 Ceq)) + Eop (Oselect (Ccomp0 Cne)) (o0:::o1:::oselect:::Enil). (** ** Constants **) @@ -288,7 +288,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then Eop (Oselect (Ccomp0 Cne)) (v0:::v1:::y0:::Enil) + then select v0 v1 y0 else Eop Oor (e1:::e2:::Enil) | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Ceq zero0)) (y0:::Enil)):::Enil)):::v0:::Enil)), @@ -297,7 +297,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then Eop (Oselect (Ccompu0 Cne)) (v0:::v1:::y0:::Enil) + then select v0 v1 y0 else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. -- cgit From a4f081bd7972c9007104942bdf90a4042397e167 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 4 Apr 2019 23:54:54 +0200 Subject: some more Oselect comparisons --- mppa_k1c/Asmblockgen.v | 2 ++ mppa_k1c/Asmblockgenproof1.v | 13 ++++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 722c4acc..d770eebc 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -737,6 +737,8 @@ Definition transl_op (match cond with | Ccomp0 cmp => OK (Pcmove (btest_for_cmpswz cmp) r0 rS r1 ::i k) + | Ccompl0 cmp => + OK (Pcmove (btest_for_cmpsdz cmp) r0 rS r1 ::i k) | _ => Error (msg "Asmblockgen Oselect") end) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e8e04019..e58c7f0c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1638,7 +1638,7 @@ Opaque Int.eq. 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; injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in *. + destruct cond in *; simpl in *; try congruence; injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in *; econstructor; split. + eapply exec_straight_one. @@ -1652,6 +1652,17 @@ Opaque Int.eq. destruct b; simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. + + eapply exec_straight_one. + simpl; reflexivity. + + 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. - (* Oselectl *) econstructor; split. + eapply exec_straight_one. -- cgit From b27d386185527d1ee9d0bb77ebe3bacffc2bf05a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 00:12:45 +0200 Subject: factor out some proofs --- mppa_k1c/Asmblockgenproof1.v | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e58c7f0c..7da86de4 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1639,10 +1639,9 @@ Opaque Int.eq. exists rs'; split. eexact A. eauto with asmgen. - (* Oselect *) destruct cond in *; simpl in *; try congruence; injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in *; - econstructor; split. - - + eapply exec_straight_one. - simpl; reflexivity. + econstructor; split; + try ( eapply exec_straight_one; + simpl; reflexivity ). + split. * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. @@ -1652,8 +1651,6 @@ Opaque Int.eq. destruct b; simpl; rewrite Pregmap.gss; constructor. * intros. rewrite Pregmap.gso; congruence. - + eapply exec_straight_one. - simpl; reflexivity. + split. * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. -- cgit From 53b6eb437c7988b44e881c7b7a9df2e735ded0ea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 06:03:21 +0200 Subject: select cmpu --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmblock.v | 17 +++++++++++++++++ mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 14 ++++++++++++++ mppa_k1c/Asmblockgenproof1.v | 26 +++++++++++++++++++++++--- mppa_k1c/PostpassSchedulingOracle.ml | 3 ++- mppa_k1c/TargetPrinter.ml | 2 +- 7 files changed, 60 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 2dc62e11..b323a67c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -215,6 +215,7 @@ Inductive instruction : Type := | 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 *) @@ -363,6 +364,7 @@ Definition basic_to_instruction (b: basic) := | PArithARRR Asmblock.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 | PArithARRR Asmblock.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 | PArithARRR (Asmblock.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmblock.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 (** ARRI32 *) | PArithARRI32 Asmblock.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 1711886d..339b44c6 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -418,6 +418,7 @@ Inductive arith_name_arrr : Type := | Pmaddw (**r multiply add word *) | Pmaddl (**r multiply add long *) | Pcmove (bt: btest) (**r conditional move *) + | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) . Inductive arith_name_arri32 : Type := @@ -1229,6 +1230,22 @@ Definition arith_eval_arrr n v1 v2 v3 := 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 end. Definition arith_eval_arri32 n v1 v2 v3 := diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index d8ca465e..96547342 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1446,6 +1446,7 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := | Pmaddw => "Pmaddw" | Pmaddl => "Pmaddl" | Pcmove _ => "Pcmove" + | Pcmoveu _ => "Pcmoveu" end. Definition string_of_name_arri32 (n: arith_name_arri32): pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index d770eebc..ce47cf52 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -367,6 +367,17 @@ 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. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -737,6 +748,9 @@ Definition transl_op (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) | _ => Error (msg "Asmblockgen Oselect") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 7da86de4..75f2005c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1638,10 +1638,12 @@ Opaque Int.eq. 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; injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in *; + 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 ). + try ( eapply exec_straight_one; simpl; reflexivity ). + (* Cmp *) + split. * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. @@ -1651,6 +1653,24 @@ Opaque Int.eq. 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. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 6f37412b..b01b7e54 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -129,6 +129,7 @@ let arith_arrr_str = function | Pmaddw -> "Pmaddw" | Pmaddl -> "Pmaddl" | Pcmove _ -> "Pcmove" + | Pcmoveu _ -> "Pcmoveu" let arith_ri32_str = "Pmake" @@ -488,7 +489,7 @@ let ab_inst_to_real = function | "Pfixedudrzz" -> Fixedudz | "Pfixeddrzz_i32" -> Fixeddz | "Pfixedudrzz_i32" -> Fixedudz - | "Pcmove" -> Cmoved + | "Pcmove" | "Pcmoveu" -> Cmoved | "Plb" -> Lbs | "Plbu" -> Lbz diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4f19e1d8..6f292460 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -529,7 +529,7 @@ module Target (*: TARGET*) = | Pmaddil (rd, rs, imm) -> fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pcmove (bt, rd, rcond, rs) -> + | 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 -- cgit From 483d0e37880dbe44af3dafdcac9b1110a37139c4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 06:15:28 +0200 Subject: Select cmplu --- mppa_k1c/Asmblockgen.v | 15 ++++++++++++++- mppa_k1c/Asmblockgenproof1.v | 18 ++++++++++++++++++ 2 files changed, 32 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ce47cf52..d8706239 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -378,6 +378,17 @@ Definition btest_for_cmpuwz (c: comparison) := | 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]. *) @@ -753,7 +764,9 @@ Definition transl_op OK (Pcmoveu bt r0 rS r1 ::i k) | Ccompl0 cmp => OK (Pcmove (btest_for_cmpsdz cmp) r0 rS r1 ::i k) - | _ => Error (msg "Asmblockgen Oselect") + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (Pcmoveu bt r0 rS r1 ::i k) end) | Oselectl, a0 :: a1 :: aS :: nil diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 75f2005c..1cb75c4c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1680,6 +1680,24 @@ Opaque Int.eq. 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 *) econstructor; split. + eapply exec_straight_one. -- cgit From 57925286e8ba6055534cd0acbcf2b411366d3e0b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 09:40:45 +0200 Subject: selectl with condition --- mppa_k1c/Asmblockgen.v | 4 +-- mppa_k1c/Asmblockgenproof1.v | 65 +++++++++++++++++++++++++++++++++------ mppa_k1c/Machregs.v | 2 +- mppa_k1c/NeedOp.v | 50 ++++++++++++++++++++++-------- mppa_k1c/Op.v | 73 +++++++++++++++++++++++++++++--------------- mppa_k1c/SelectOp.vp | 16 ++++++++-- mppa_k1c/ValueAOp.v | 25 +++++++-------- 7 files changed, 171 insertions(+), 64 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index d8706239..b3478a9a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -751,7 +751,8 @@ Definition transl_op do rd <- ireg_of res; transl_cond_op cmp rd args k - | Oselect cond, a0 :: a1 :: aS :: nil => + | Oselect cond, a0 :: a1 :: aS :: nil + | Oselectl cond, a0 :: a1 :: aS :: nil => assertion (mreg_eq a0 res); do r0 <- ireg_of a0; do r1 <- ireg_of a1; @@ -769,7 +770,6 @@ Definition transl_op OK (Pcmoveu bt r0 rS r1 ::i k) end) - | Oselectl, a0 :: a1 :: aS :: nil | Oselectf, a0 :: a1 :: aS :: nil | Oselectfs, a0 :: a1 :: aS :: nil => assertion (mreg_eq a0 res); diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1cb75c4c..874e40a8 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1698,20 +1698,67 @@ Opaque Int.eq. * intros. rewrite Pregmap.gso; congruence. -- (* Oselectl *) - econstructor; split. - + eapply exec_straight_one. - simpl; reflexivity. +- (* 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_selectl. - destruct (rs x1) eqn:eqX1; try constructor. + * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. - simpl. - rewrite int_eq_comm. - destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; 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 *) econstructor; split. + eapply exec_straight_one. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index daf724ea..ddf730a9 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -209,7 +209,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl | Oselectf | Oselectfs => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf | Oselectfs => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index d385ebac..a276cda1 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -117,7 +117,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) + | Oselect _ | Oselectl _ | Oselectf | Oselectfs => op3 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -289,22 +289,46 @@ Proof. Qed. Lemma selectl_sound: - forall v0 w0 v1 w1 v2 w2 x, + 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 v0 v1 v2) (eval_selectl w0 w1 w2) x. + vagree (eval_selectl cond v0 v1 v2 m1) (eval_selectl cond w0 w1 w2 m2) x. Proof. - unfold default; intros. - destruct x; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - inv H. inv H0. inv H1. simpl. - constructor. + 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. Qed. Lemma selectf_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 51d70693..045946fd 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -194,8 +194,8 @@ 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 r3 then r2 else r1] *) - | Oselectl (**r [rd = if r3 then r2 else r1] *) + | 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 (**r [rd = if r3 then r2 else r1] *) | Oselectfs. (**r [rd = if r3 then r2 else r1] *) @@ -303,23 +303,27 @@ Proof. destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. Qed. -Definition eval_selectl (v0 : val) (v1 : val) (vselect : val) : val := - match vselect with - | Vint iselect => - match v0 with - | Vlong i0 => - match v1 with - | Vlong i1 => - Vlong (if Int.cmp Ceq Int.zero iselect - then i0 - else i1) - | _ => Vundef - end - | _ => Vundef - end - | _ => Vundef +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 + 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 (v0 : val) (v1 : val) (vselect : val) : val := match vselect with | Vint iselect => @@ -483,7 +487,7 @@ Definition eval_operation | 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, v0::v1::vselect::nil => Some (eval_selectl v0 v1 vselect) + | (Oselectl cond), v0::v1::vselect::nil => Some (eval_selectl cond v0 v1 vselect m) | Oselectf, v0::v1::vselect::nil => Some (eval_selectf v0 v1 vselect) | Oselectfs, v0::v1::vselect::nil => Some (eval_selectfs v0 v1 vselect) | _, _ => None @@ -676,7 +680,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocmp c => (type_of_condition c, Tint) | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint) - | Oselectl => (Tlong :: Tlong :: Tint :: nil, Tlong) + | Oselectl cond => (Tlong :: Tlong :: (arg_type_of_condition0 cond) :: nil, Tlong) | Oselectf => (Tfloat :: Tfloat :: Tint :: nil, Tfloat) | Oselectfs => (Tsingle :: Tsingle :: Tint :: nil, Tsingle) end. @@ -924,7 +928,15 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (_ && _); simpl; trivial. destruct (Val.cmp_different_blocks _); simpl; trivial. (* selectl *) - - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. + - 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; destruct v2; simpl in *; try discriminate; trivial. (* selectfs *) @@ -1092,6 +1104,9 @@ Definition op_depends_on_memory (op: operation) : bool := | Oselect (Ccompu0 _) => negb Archi.ptr64 | Oselect (Ccomplu0 _) => Archi.ptr64 + + | Oselectl (Ccompu0 _) => negb Archi.ptr64 + | Oselectl (Ccomplu0 _) => Archi.ptr64 | _ => false end. @@ -1104,7 +1119,7 @@ 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_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + unfold eval_select, eval_selectl, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1488,9 +1503,19 @@ Proof. assumption. * rewrite Hcond'. constructor. (* selectl *) - - inv H3; simpl; try constructor. - inv H4; simpl; try constructor. - inv H2; simpl; constructor. + - 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 *) - inv H3; simpl; try constructor. inv H4; simpl; try constructor. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 906d6791..eeb3ffae 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -62,10 +62,20 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -Definition select o0 o1 oselect := +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. + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := @@ -288,7 +298,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then select v0 v1 y0 + 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)), @@ -297,7 +307,7 @@ Nondetfunction or (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int.eq zero0 Int.zero && Int.eq zero1 Int.zero - then select v0 v1 y0 + then select_base v0 v1 y0 else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index e791cc40..62cfa85e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -56,12 +56,9 @@ Definition eval_static_select (cond : condition0) (v0 v1 vselect : aval) : aval | _ => Vtop end. -Definition eval_static_selectl (v0 v1 vselect : aval) : aval := - match vselect with - | I iselect => - if Int.eq Int.zero iselect - then binop_long (fun x0 x1 => x0) v0 v1 - else binop_long (fun x0 x1 => x1) v0 v1 +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. @@ -208,7 +205,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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, v0::v1::vselect::nil => eval_static_selectl v0 v1 vselect + | (Oselectl cond), v0::v1::vselect::nil => eval_static_selectl cond v0 v1 vselect | Oselectf, v0::v1::vselect::nil => eval_static_selectf v0 v1 vselect | Oselectfs, v0::v1::vselect::nil => eval_static_selectfs v0 v1 vselect | _, _ => Vbot @@ -307,11 +304,15 @@ Proof. + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. apply vmatch_ifptr_i. (* selectl *) - - inv H2; simpl; try constructor. - + destruct (Int.eq _ _); apply binop_long_sound; trivial. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + - 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 *) - inv H2; simpl; try constructor. + destruct (Int.eq _ _); apply binop_float_sound; trivial. -- cgit From 7cf2665680872984dd62468b3e921276196d0290 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 5 Apr 2019 11:50:46 +0200 Subject: Possible fix pour l'issue #82 (mauvais calcul de taille de bundle pour les store) --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 6bb1c6b8..f7a35443 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -304,7 +304,7 @@ let encode_imm (imm:int64) = else let length = unsigned_length imm in if length <= 6 then U6 - else if length <= 10 then S10 + else if length <= 9 then S10 (* Special case for S10 - stay signed no matter what *) else if length <= 32 then U27L5 else if length <= 37 then U27L10 else if length <= 64 then E27U27L10 -- cgit From e4bc9aa604977ee168c2f580d3fc3c3521f6c25c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 13:36:56 +0200 Subject: Oselectf, Oselectfs with condition --- mppa_k1c/Asmblockgen.v | 12 +--- mppa_k1c/Asmblockgenproof1.v | 128 ++++++++++++++++++++++++++++++++------ mppa_k1c/Machregs.v | 2 +- mppa_k1c/NeedOp.v | 98 +++++++++++++++++++++-------- mppa_k1c/Op.v | 142 +++++++++++++++++++++++++++++-------------- mppa_k1c/SelectOp.vp | 14 +++++ mppa_k1c/ValueAOp.v | 50 +++++++-------- 7 files changed, 323 insertions(+), 123 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index b3478a9a..392b7953 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -752,7 +752,9 @@ Definition transl_op transl_cond_op cmp rd args k | Oselect cond, a0 :: a1 :: aS :: nil - | Oselectl 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; @@ -769,14 +771,6 @@ Definition transl_op do bt <- btest_for_cmpudz cmp; OK (Pcmoveu bt r0 rS r1 ::i k) end) - - | Oselectf, a0 :: a1 :: aS :: nil - | Oselectfs, a0 :: a1 :: aS :: nil => - assertion (mreg_eq a0 res); - do r0 <- ireg_of a0; - do r1 <- ireg_of a1; - do rS <- ireg_of aS; - OK (Pcmove BTwnez r0 rS r1 ::i k) | _, _ => Error(msg "Asmgenblock.transl_op") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 874e40a8..6cf5c60c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1698,7 +1698,7 @@ Opaque Int.eq. * intros. rewrite Pregmap.gso; congruence. -- (* Oselect *) +- (* Oselectl *) destruct cond in *; simpl in *; try congruence; try monadInv EQ3; try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); @@ -1760,31 +1760,125 @@ Opaque Int.eq. rewrite Pregmap.gso; congruence. - (* Oselectf *) - econstructor; split. - + eapply exec_straight_one. - simpl; reflexivity. + 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_selectf. - destruct (rs x1) eqn:eqX1; try constructor. + * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. - simpl. - rewrite int_eq_comm. - destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; 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 *) - econstructor; split. - + eapply exec_straight_one. - simpl; reflexivity. + 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_selectfs. - destruct (rs x1) eqn:eqX1; try constructor. + * unfold eval_select. destruct (rs x) eqn:eqX; try constructor. destruct (rs x0) eqn:eqX0; try constructor. - simpl. - rewrite int_eq_comm. - destruct (Int.eq i Int.zero); simpl; rewrite Pregmap.gss; 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. Qed. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ddf730a9..f36962f3 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -209,7 +209,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf | Oselectfs => true + | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index a276cda1..ba051c90 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -117,7 +117,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) + | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -332,41 +332,89 @@ Proof. Qed. Lemma selectf_sound: - forall v0 w0 v1 w1 v2 w2 x, + 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 v0 v1 v2) (eval_selectf w0 w1 w2) x. + vagree (eval_selectf cond v0 v1 v2 m1) (eval_selectf cond w0 w1 w2 m2) x. Proof. - unfold default; intros. - destruct x; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - inv H. inv H0. inv H1. simpl. - constructor. + 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. Qed. Lemma selectfs_sound: - forall v0 w0 v1 w1 v2 w2 x, + 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 v0 v1 v2) (eval_selectfs w0 w1 w2) x. + vagree (eval_selectfs cond v0 v1 v2 m1) (eval_selectfs cond w0 w1 w2 m2) x. Proof. - unfold default; intros. - destruct x; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - - destruct v2; simpl; trivial. - destruct v0; simpl; trivial. - destruct v1; simpl; trivial. - inv H. inv H0. inv H1. simpl. - constructor. + 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. Qed. Remark default_idem: forall nv, default (default nv) = default nv. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 045946fd..14758bee 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -194,10 +194,10 @@ 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 (**r [rd = if r3 then r2 else r1] *) - | Oselectfs. (**r [rd = if r3 then r2 else r1] *) + | 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] *) (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -324,40 +324,48 @@ Proof. destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. Qed. -Definition eval_selectf (v0 : val) (v1 : val) (vselect : val) : val := - match vselect with - | Vint iselect => - match v0 with - | Vfloat i0 => - match v1 with - | Vfloat i1 => - Vfloat (if Int.cmp Ceq Int.zero iselect - then i0 - else i1) - | _ => Vundef - end - | _ => Vundef - end - | _ => Vundef +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_selectfs (v0 : val) (v1 : val) (vselect : val) : val := - match vselect with - | Vint iselect => - match v0 with - | Vsingle i0 => - match v1 with - | Vsingle i1 => - Vsingle (if Int.cmp Ceq Int.zero iselect - then i0 - else i1) - | _ => Vundef - end - | _ => Vundef - end - | _ => Vundef +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 := @@ -488,8 +496,8 @@ Definition eval_operation | 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, v0::v1::vselect::nil => Some (eval_selectf v0 v1 vselect) - | Oselectfs, v0::v1::vselect::nil => Some (eval_selectfs v0 v1 vselect) + | (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) | _, _ => None end. @@ -681,8 +689,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint) | Oselectl cond => (Tlong :: Tlong :: (arg_type_of_condition0 cond) :: nil, Tlong) - | Oselectf => (Tfloat :: Tfloat :: Tint :: nil, Tfloat) - | Oselectfs => (Tsingle :: Tsingle :: Tint :: nil, Tsingle) + | Oselectf cond => (Tfloat :: Tfloat :: (arg_type_of_condition0 cond) :: nil, Tfloat) + | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -938,9 +946,23 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (Val.cmp_different_blocks _); simpl; trivial. (* selectf *) - - destruct v0; destruct v1; destruct v2; simpl in *; try discriminate; trivial. + - 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; destruct v2; simpl in *; try discriminate; trivial. + - 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. Qed. End SOUNDNESS. @@ -1107,6 +1129,12 @@ Definition op_depends_on_memory (op: operation) : bool := | 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. @@ -1119,7 +1147,7 @@ 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_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + unfold eval_select, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1517,13 +1545,33 @@ Proof. assumption. * rewrite Hcond'. constructor. (* selectf *) - - inv H3; simpl; try constructor. - inv H4; simpl; try constructor. - inv H2; simpl; constructor. + - 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 *) - - inv H3; simpl; try constructor. - inv H4; simpl; try constructor. - inv H2; simpl; constructor. + - 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. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index eeb3ffae..71e0eff3 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -76,6 +76,20 @@ Definition selectl_base o0 o1 oselect := 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. + (** ** Constants **) Definition addrsymbol (id: ident) (ofs: ptrofs) := diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 62cfa85e..f17bd765 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -62,21 +62,15 @@ Definition eval_static_selectl (cond : condition0) (v0 v1 vselect : aval) : aval | _ => Vtop end. -Definition eval_static_selectf (v0 v1 vselect : aval) : aval := - match vselect with - | I iselect => - if Int.eq Int.zero iselect - then binop_float (fun x0 x1 => x0) v0 v1 - else binop_float (fun x0 x1 => x1) v0 v1 +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 (v0 v1 vselect : aval) : aval := - match vselect with - | I iselect => - if Int.eq Int.zero iselect - then binop_single (fun x0 x1 => x0) v0 v1 - else binop_single (fun x0 x1 => x1) v0 v1 +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. @@ -206,8 +200,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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, v0::v1::vselect::nil => eval_static_selectf v0 v1 vselect - | Oselectfs, v0::v1::vselect::nil => eval_static_selectfs 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 | _, _ => Vbot end. @@ -314,17 +308,25 @@ Proof. + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. apply vmatch_ifptr_l. (* selectf *) - - inv H2; simpl; try constructor. - + destruct (Int.eq _ _); apply binop_float_sound; trivial. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + - 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 *) - - inv H2; simpl; try constructor. - + destruct (Int.eq _ _); apply binop_single_sound; trivial. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. - + destruct (Int.eq _ _); destruct a1; destruct a0; eauto; constructor. + - 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. Qed. End SOUNDNESS. -- cgit From 27d1525b819cf4f82e4a2f2943596001b50c44b7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 5 Apr 2019 15:04:46 +0200 Subject: reinstated the orl selectl construct --- mppa_k1c/SelectLong.vp | 9 +++------ mppa_k1c/SelectLongproof.v | 8 ++++---- 2 files changed, 7 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index f8f5bf3b..f7cb3c82 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -286,10 +286,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 Oorl (e1:::e2:::Enil) - end. - - (* | (Eop Oandl ((Eop Ocast32signed ((Eop Oneg ((Eop (Ocmp (Ccomplimm Ceq zero0)) (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), @@ -299,9 +295,10 @@ Nondetfunction orl (e1: expr) (e2: expr) := if same_expr_pure y0 y1 && Int64.eq zero0 Int64.zero && Int64.eq zero1 Int64.zero - then Eop Oselectl (v0:::v1:::y0:::Enil) + then Eop (Oselectl (Ccompl0 Cne)) (v0:::v1:::y0:::Enil) else Eop Oorl (e1:::e2:::Enil) - *) + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. Nondetfunction xorlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index e18de2ee..3fab35b3 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -452,7 +452,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. @@ -504,7 +503,8 @@ Proof. TrivialExists. simpl. f_equal. - unfold selectl. + rewrite eval_selectl_to2. + unfold eval_selectl2. destruct vtest; simpl; trivial. rewrite Val.andl_commut. destruct v4; simpl; trivial. @@ -512,7 +512,7 @@ Proof. rewrite Val.orl_commut. destruct v9; simpl; trivial. rewrite int64_eq_commut. - destruct (Int64.eq i1 Int64.zero); simpl. + 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. @@ -526,7 +526,7 @@ Proof. rewrite Int64.and_mone. rewrite Int64.and_zero. rewrite Int64.or_zero. - reflexivity. *) + reflexivity. - TrivialExists. Qed. -- cgit From 9d94664fa180d909c43992a4cbdf6808fb9c4289 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 5 Apr 2019 15:54:51 +0200 Subject: #90 Asmvliw/Asmblock refactoring attempt --- mppa_k1c/Asm.v | 336 ++++----- mppa_k1c/Asmblock.v | 1350 +-------------------------------- mppa_k1c/Asmblockdeps.v | 14 +- mppa_k1c/Asmblockgen.v | 6 +- mppa_k1c/Asmblockgenproof.v | 28 +- mppa_k1c/Asmexpand.ml | 116 +-- mppa_k1c/Asmvliw.v | 1363 +++++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 6 +- mppa_k1c/PostpassSchedulingproof.v | 4 +- mppa_k1c/TargetPrinter.ml | 16 +- mppa_k1c/lib/Asmblockgenproof0.v | 6 +- 11 files changed, 1634 insertions(+), 1611 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 115c8d6d..893552c4 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -220,195 +220,195 @@ Inductive instruction : Type := Definition control_to_instruction (c: control) := match c with - | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmblock.Pret => Pret - | PCtlFlow (Asmblock.Pcall l) => Pcall l - | PCtlFlow (Asmblock.Picall r) => Picall r - | PCtlFlow (Asmblock.Pgoto l) => Pgoto l - | PCtlFlow (Asmblock.Pigoto l) => Pigoto l - | PCtlFlow (Asmblock.Pj_l l) => Pj_l l - | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmblock.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmblock.Pjumptable r label) => Pjumptable r label + | 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 *) - | Asmblock.Pget rd rs => Pget rd rs - | Asmblock.Pset rd rs => Pset rd rs - | Asmblock.Pnop => Pnop - | Asmblock.Pallocframe sz pos => Pallocframe sz pos - | Asmblock.Pfreeframe sz pos => Pfreeframe sz pos + | 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 (Asmblock.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs (* RR *) - | PArithRR Asmblock.Pmv rd rs => Pmv rd rs - | PArithRR Asmblock.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmblock.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmblock.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmblock.Pzxwd rd rs => Pzxwd rd rs - | PArithRR Asmblock.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmblock.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmblock.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmblock.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmblock.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmblock.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmblock.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmblock.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmblock.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmblock.Pfloatudrnsz_i32 rd rs => Pfloatudrnsz_i32 rd rs - | PArithRR Asmblock.Pfloatdrnsz_i32 rd rs => Pfloatdrnsz_i32 rd rs - | PArithRR Asmblock.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmblock.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmblock.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmblock.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmblock.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmblock.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + | 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.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.Pfloatudrnsz_i32 rd rs => Pfloatudrnsz_i32 rd rs + | PArithRR Asmvliw.Pfloatdrnsz_i32 rd rs => Pfloatdrnsz_i32 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 Asmblock.Pmake rd imm => Pmake rd imm + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm (* RI64 *) - | PArithRI64 Asmblock.Pmakel rd imm => Pmakel rd imm + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm (* RF32 *) - | PArithRF32 Asmblock.Pmakefs rd imm => Pmakefs rd imm + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm (* RF64 *) - | PArithRF64 Asmblock.Pmakef rd imm => Pmakef rd imm + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm (* RRR *) - | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmblock.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmblock.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmblock.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmblock.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmblock.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmblock.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmblock.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmblock.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmblock.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmblock.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmblock.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR Asmblock.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR Asmblock.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmblock.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmblock.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmblock.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmblock.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmblock.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmblock.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmblock.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmblock.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmblock.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmblock.Psral rd rs1 rs2 => Psral rd rs1 rs2 - - | PArithRRR Asmblock.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmblock.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmblock.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmblock.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmblock.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmblock.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | 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.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.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 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 Asmblock.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmblock.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmblock.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmblock.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmblock.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmblock.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmblock.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmblock.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmblock.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmblock.Psrail rd rs imm => Psrail rd rs imm + | 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.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.Psrail rd rs imm => Psrail rd rs imm (* RRI64 *) - | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmblock.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 Asmblock.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmblock.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmblock.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmblock.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmblock.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmblock.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmblock.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmblock.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmblock.Pornil rd rs imm => Pornil rd rs imm + | 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 Asmblock.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmblock.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 (** ARRI32 *) - | PArithARRI32 Asmblock.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm (** ARRI64 *) - | PArithARRI64 Asmblock.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm (** Load *) - | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra (AOff ofs) - | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra (AOff ofs) - | PLoadRRO Asmblock.Plh rd ra ofs => Plh rd ra (AOff ofs) - | PLoadRRO Asmblock.Plhu rd ra ofs => Plhu rd ra (AOff ofs) - | PLoadRRO Asmblock.Plw rd ra ofs => Plw rd ra (AOff ofs) - | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) - | PLoadRRO Asmblock.Pld rd ra ofs => Pld rd ra (AOff ofs) - | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) - | PLoadRRO Asmblock.Pfls rd ra ofs => Pfls rd ra (AOff ofs) - | PLoadRRO Asmblock.Pfld rd ra ofs => Pfld rd ra (AOff ofs) - - | PLoadRRR Asmblock.Plb rd ra ro => Plb rd ra (AReg ro) - | PLoadRRR Asmblock.Plbu rd ra ro => Plbu rd ra (AReg ro) - | PLoadRRR Asmblock.Plh rd ra ro => Plh rd ra (AReg ro) - | PLoadRRR Asmblock.Plhu rd ra ro => Plhu rd ra (AReg ro) - | PLoadRRR Asmblock.Plw rd ra ro => Plw rd ra (AReg ro) - | PLoadRRR Asmblock.Plw_a rd ra ro => Plw_a rd ra (AReg ro) - | PLoadRRR Asmblock.Pld rd ra ro => Pld rd ra (AReg ro) - | PLoadRRR Asmblock.Pld_a rd ra ro => Pld_a rd ra (AReg ro) - | PLoadRRR Asmblock.Pfls rd ra ro => Pfls rd ra (AReg ro) - | PLoadRRR Asmblock.Pfld rd ra ro => Pfld rd ra (AReg ro) + | 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) + + | 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) (** Store *) - | PStoreRRO Asmblock.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmblock.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmblock.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmblock.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmblock.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmblock.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmblock.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmblock.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmblock.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + | 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) end. @@ -449,7 +449,7 @@ Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. Definition genv := Genv.t fundef unit. -Definition function_proj (f: function) := Asmblock.mkfunction (fn_sig f) (fn_blocks f). +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. @@ -457,19 +457,19 @@ Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_ Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p. *) -Definition fundef_proj (fu: fundef) : Asmblock.fundef := +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 Asmblock.fundef unit := +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) : Asmblock.genv := +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); @@ -488,13 +488,13 @@ Qed. Next Obligation. Qed. Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmblock.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) : Asmblock.program := +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 @@ -513,16 +513,16 @@ Qed. (** transf_program *) -Program Definition transf_function (f: Asmblock.function) : function := - {| fn_sig := Asmblock.fn_sig f; fn_blocks := Asmblock.fn_blocks f; - fn_code := unfold (Asmblock.fn_blocks f) |}. +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 : Asmblock.fundef -> fundef := AST.transf_fundef transf_function. +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. Proof. @@ -559,7 +559,7 @@ Proof. Qed. *) -Definition transf_program : Asmblock.program -> program := transform_program transf_fundef. +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 -> @@ -582,7 +582,7 @@ Proof. rewrite transf_fundef_proj. auto. Qed. -Definition match_prog (p: Asmblock.program) (tp: program) := +Definition match_prog (p: Asmvliw.program) (tp: program) := match_program (fun _ f tf => tf = transf_fundef f) eq p tp. Lemma transf_program_match: @@ -615,7 +615,7 @@ Qed. Section PRESERVATION. -Variable prog: Asmblock.program. +Variable prog: Asmvliw.program. Variable tprog: program. Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index e612576f..3bcb321d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -31,1202 +31,18 @@ Require Import Locations. Require Stacklayout. Require Import Conventions. Require Import Errors. - -(** * Abstract syntax *) - -(** General Purpose registers. -*) - -Inductive gpreg: Type := - | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg - | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg - | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg - | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg - | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg - | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg - | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg - | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg - | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg - | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg - | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg - | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg - | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. - -Definition ireg := gpreg. -Definition freg := gpreg. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -(** 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 - | PC: preg - . - -Coercion IR: gpreg >-> preg. - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) - -Notation "'SP'" := GPR12 (only parsing) : asm. -Notation "'FP'" := GPR17 (only parsing) : asm. -Notation "'MFP'" := R17 (only parsing) : asm. -Notation "'GPRA'" := GPR16 (only parsing) : asm. -Notation "'RTMP'" := GPR32 (only parsing) : asm. - -Inductive btest: Type := - | BTdnez (**r Double Not Equal to Zero *) - | BTdeqz (**r Double Equal to Zero *) - | BTdltz (**r Double Less Than Zero *) - | 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 *) - | BTweqz (**r Word Equal to Zero *) - | BTwltz (**r Word Less Than Zero *) - | BTwgez (**r Word Greater Than or Equal to Zero *) - | BTwlez (**r Word Less Than or Equal to Zero *) - | BTwgtz (**r Word Greater Than Zero *) - . - -Inductive itest: Type := - | ITne (**r Not Equal *) - | ITeq (**r Equal *) - | ITlt (**r Less Than *) - | ITge (**r Greater Than or Equal *) - | ITle (**r Less Than or Equal *) - | ITgt (**r Greater Than *) - | ITneu (**r Unsigned Not Equal *) - | ITequ (**r Unsigned Equal *) - | ITltu (**r Less Than Unsigned *) - | 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 := - | FTone (**r Ordered and Not Equal *) - | FTueq (**r Unordered or Equal *) - | FToeq (**r Ordered and Equal *) - | FTune (**r Unordered or Not Equal *) - | FTolt (**r Ordered and Less Than *) - | FTuge (**r Unordered or Greater Than or Equal *) - | FToge (**r Ordered and Greater Than or Equal *) - | FTult (**r Unordered or Less Than *) - . - -(** Offsets for load and store instructions. An offset is either an - immediate integer or the low part of a symbol. *) - -Inductive offset : Type := - | Ofsimm (ofs: ptrofs) - | Ofslow (id: ident) (ofs: ptrofs). - -(** We model a subset of the K1c instruction set. In particular, we do not - support floats yet. - - Although it is possible to use the 32-bits mode, for now we don't support it. - - We follow a design close to the one used for the Risc-V port: one set of - pseudo-instructions for 32-bit integer arithmetic, with suffix W, another - set for 64-bit integer arithmetic, with suffix L. - - When mapping to actual instructions, the OCaml code in TargetPrinter.ml - throws an error if we are not in 64-bits mode. -*) - -(** * Instructions *) - -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 -*) -Inductive ex_instruction : Type := - (* Pseudo-instructions *) -(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) - - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) -. - -(** FIXME: comment not up to date ! - - - The pseudo-instructions are the following: - -- [Ploadsymbol]: load the address of a symbol in an integer register. - Expands to the [la] assembler pseudo-instruction, which does the right - thing even if we are in PIC mode. - -- [Pallocframe sz pos]: in the formal semantics, this - pseudo-instruction allocates a memory block with bounds [0] and - [sz], stores the value of the stack pointer at offset [pos] in this - block, and sets the stack pointer to the address of the bottom of - this block. - In the printed ASM assembly code, this allocation is: -<< - mv x30, sp - sub sp, sp, #sz - sw x30, #pos(sp) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. - -- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction - reads the word at [pos] of the block pointed by the stack pointer, - frees this block, and sets the stack pointer to the value read. - In the printed ASM assembly code, this freeing is just an increment of [sp]: -<< - add sp, sp, #sz ->> - Again, our memory model cannot comprehend that this operation - frees (logically) the current stack frame. - -- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table - as follows: -<< - la x31, table - add x31, x31, reg - jr x31 -table: .long table[0], table[1], ... ->> - Note that [reg] contains 4 times the index of the desired table entry. -*) - -(** Control Flow instructions *) -Inductive cf_instruction : Type := - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (r: ireg) (**r function call on register value *) - | Pjumptable (r: ireg) (labels: list label) (**r N-way branch through a jump table (pseudo) *) - - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (r: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - - (* Conditional branches *) - | 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 *) -. - -(** Loads **) -Inductive load_name : Type := - | Plb (**r load byte *) - | Plbu (**r load byte unsigned *) - | Plh (**r load half word *) - | Plhu (**r load half word unsigned *) - | Plw (**r load int32 *) - | Plw_a (**r load any32 *) - | Pld (**r load int64 *) - | Pld_a (**r load any64 *) - | Pfls (**r load float *) - | Pfld (**r load 64-bit float *) -. - -Inductive ld_instruction : Type := - | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) -. - -Coercion PLoadRRO: load_name >-> Funclass. -Coercion PLoadRRR: load_name >-> Funclass. - -(** Stores **) -Inductive store_name : Type := - | Psb (**r store byte *) - | Psh (**r store half byte *) - | Psw (**r store int32 *) - | Psw_a (**r store any32 *) - | Psd (**r store int64 *) - | Psd_a (**r store any64 *) - | Pfss (**r store float *) - | Pfsd (**r store 64-bit float *) -. - -Inductive st_instruction : Type := - | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) - | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) -. - -Coercion PStoreRRO: store_name >-> Funclass. -Coercion PStoreRRR: store_name >-> Funclass. - -(** Arithmetic instructions **) -Inductive arith_name_r : Type := - | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) -. - -Inductive arith_name_rr : Type := - | Pmv (**r register move *) - | Pnegw (**r negate word *) - | Pnegl (**r negate long *) - | Pcvtl2w (**r Convert Long to Word *) - | Psxwd (**r Sign Extend Word to Double Word *) - | Pzxwd (**r Zero Extend Word to Double Word *) - - | Pfabsd (**r float absolute double *) - | Pfabsw (**r float absolute word *) - | Pfnegd (**r float negate double *) - | Pfnegw (**r float negate 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) *) - | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) - | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) - | Pfloatudrnsz_i32 (**r Floating Point Conversion from integer (unsigned int -> float) *) - | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) - | Pfloatdrnsz_i32 (**r Floating Point Conversion from integer (int -> float) *) - | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) - | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) - | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) - | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) - | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) - | Pfixedudrzz_i32 (**r Integer conversion from floating point (float -> unsigned int) *) -. - -Inductive arith_name_ri32 : Type := - | Pmake (**r load immediate *) -. - -Inductive arith_name_ri64 : Type := - | Pmakel (**r load immediate long *) -. - -Inductive arith_name_rf32 : Type := - | Pmakefs (**r load immediate single *) -. - -Inductive arith_name_rf64 : Type := - | Pmakef (**r load immediate float *) -. - -Inductive arith_name_rrr : Type := - | Pcompw (it: itest) (**r comparison word *) - | Pcompl (it: itest) (**r comparison long *) - | Pfcompw (ft: ftest) (**r comparison float32 *) - | Pfcompl (ft: ftest) (**r comparison float64 *) - - | Paddw (**r add word *) - | Psubw (**r sub word *) - | Pmulw (**r mul word *) - | Pandw (**r and word *) - | Pnandw (**r nand word *) - | Porw (**r or word *) - | Pnorw (**r nor word *) - | Pxorw (**r xor word *) - | Pnxorw (**r nxor word *) - | Pandnw (**r andn word *) - | Pornw (**r orn word *) - | Psraw (**r shift right arithmetic word *) - | Psrlw (**r shift right logical word *) - | Psllw (**r shift left logical word *) - - | Paddl (**r add long *) - | Psubl (**r sub long *) - | Pandl (**r and long *) - | Pnandl (**r nand long *) - | Porl (**r or long *) - | Pnorl (**r nor long *) - | Pxorl (**r xor long *) - | Pnxorl (**r nxor long *) - | Pandnl (**r andn long *) - | Pornl (**r orn long *) - | Pmull (**r mul long (low part) *) - | Pslll (**r shift left logical long *) - | Psrll (**r shift right logical long *) - | Psral (**r shift right arithmetic long *) - - | Pfaddd (**r float add double *) - | Pfaddw (**r float add word *) - | Pfsbfd (**r float sub double *) - | Pfsbfw (**r float sub word *) - | Pfmuld (**r float multiply double *) - | Pfmulw (**r float multiply word *) -. - -Inductive arith_name_rri32 : Type := - | Pcompiw (it: itest) (**r comparison imm word *) - - | Paddiw (**r add imm word *) - | Pmuliw (**r add imm word *) - | Pandiw (**r and imm word *) - | Pnandiw (**r nand imm word *) - | Poriw (**r or imm word *) - | Pnoriw (**r nor imm word *) - | Pxoriw (**r xor imm word *) - | Pnxoriw (**r nxor imm word *) - | Pandniw (**r andn word *) - | Porniw (**r orn word *) - | Psraiw (**r shift right arithmetic imm word *) - | Psrliw (**r shift right logical imm word *) - | Pslliw (**r shift left logical imm word *) - | Proriw (**r rotate right imm word *) - | Psllil (**r shift left logical immediate long *) - | Psrlil (**r shift right logical immediate long *) - | Psrail (**r shift right arithmetic immediate long *) -. - -Inductive arith_name_rri64 : Type := - | Pcompil (it: itest) (**r comparison imm long *) - | Paddil (**r add immediate long *) - | Pmulil (**r mul immediate long *) - | Pandil (**r and immediate long *) - | Pnandil (**r nand immediate long *) - | Poril (**r or immediate long *) - | Pnoril (**r nor immediate long *) - | Pxoril (**r xor immediate long *) - | Pnxoril (**r nxor immediate long *) - | Pandnil (**r andn immediate long *) - | Pornil (**r orn immediate long *) -. - -Inductive arith_name_arrr : Type := - | Pmaddw (**r multiply add word *) - | Pmaddl (**r multiply add long *) -. - -Inductive arith_name_arri32 : Type := - | Pmaddiw (**r multiply add word *) -. - -Inductive arith_name_arri64 : Type := - | Pmaddil (**r multiply add long *) -. - -Inductive ar_instruction : Type := - | PArithR (i: arith_name_r) (rd: ireg) - | PArithRR (i: arith_name_rr) (rd rs: ireg) - | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) - | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) - | PArithRF32 (i: arith_name_rf32) (rd: ireg) (imm: float32) - | PArithRF64 (i: arith_name_rf64) (rd: ireg) (imm: float) - | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) - | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) - | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) - | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) - | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) - | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) -. - -Coercion PArithR: arith_name_r >-> Funclass. -Coercion PArithRR: arith_name_rr >-> Funclass. -Coercion PArithRI32: arith_name_ri32 >-> Funclass. -Coercion PArithRI64: arith_name_ri64 >-> Funclass. -Coercion PArithRF32: arith_name_rf32 >-> Funclass. -Coercion PArithRF64: arith_name_rf64 >-> Funclass. -Coercion PArithRRR: arith_name_rrr >-> Funclass. -Coercion PArithRRI32: arith_name_rri32 >-> Funclass. -Coercion PArithRRI64: arith_name_rri64 >-> Funclass. -Coercion PArithARRR: arith_name_arrr >-> Funclass. -Coercion PArithARRI32: arith_name_arri32 >-> Funclass. -Coercion PArithARRI64: arith_name_arri64 >-> Funclass. - -Inductive basic : Type := - | PArith (i: ar_instruction) - | PLoad (i: ld_instruction) - | PStore (i: st_instruction) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pnop (**r virtual instruction that does nothing *) -. - -Coercion PLoad: ld_instruction >-> basic. -Coercion PStore: st_instruction >-> basic. -Coercion PArith: ar_instruction >-> basic. - - -Inductive control : Type := - | PExpand (i: ex_instruction) - | PCtlFlow (i: cf_instruction) -. - -Coercion PExpand: ex_instruction >-> control. -Coercion PCtlFlow: cf_instruction >-> control. - - -(** * Definition of a bblock *) - -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. - -Definition non_empty_bblock (body: list basic) (exit: option control): Prop - := body <> nil \/ exit <> None. - -Definition non_empty_body (body: list basic): bool := - match body with - | nil => false - | _ => true - end. - -Definition non_empty_exit (exit: option control): bool := - match exit with - | None => false - | _ => true - end. - -Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. - -Lemma non_empty_bblock_refl: - forall body exit, - non_empty_bblock body exit <-> - Is_true (non_empty_bblockb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. intros. inversion H; contradiction. - - destruct body; destruct exit. - all: simpl; auto. - all: intros; try (right; discriminate); try (left; discriminate). - contradiction. -Qed. - -Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, - exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. - -Definition builtin_aloneb (body: list basic) (exit: option control) := - match exit with - | Some (PExpand (Pbuiltin _ _ _)) => - match body with - | nil => true - | _ => false - end - | _ => true - end. - -Lemma builtin_alone_refl: - forall body exit, - builtin_alone body exit <-> Is_true (builtin_aloneb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. - all: exploreInst; simpl; auto. - unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. - assert (b :: body = nil). eapply H; eauto. discriminate. - - destruct body; destruct exit. - all: simpl; auto; try constructor. - + exploreInst; try discriminate. - simpl. contradiction. - + intros. discriminate. -Qed. - -Definition wf_bblockb (body: list basic) (exit: option control) := - (non_empty_bblockb body exit) && (builtin_aloneb body exit). - -Definition wf_bblock (body: list basic) (exit: option control) := - non_empty_bblock body exit /\ builtin_alone body exit. - -Lemma wf_bblock_refl: - forall body exit, - wf_bblock body exit <-> Is_true (wf_bblockb body exit). -Proof. - intros. split. - - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - apply andb_prop_intro. auto. - - intros. apply andb_prop_elim in H. inv H. - apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - unfold wf_bblock. split; auto. -Qed. - -(** A bblock is well-formed if he contains at least one instruction, - and if there is a builtin then it must be alone in this bblock. *) - -Record bblock := mk_bblock { - header: list label; - body: list basic; - exit: option control; - correct: Is_true (wf_bblockb body exit) -}. - -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. - destruct b; simpl; auto. - - destruct p1, p2; auto. - - destruct p1. -Qed. - -Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. -Proof. - destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. - intros; subst. - rewrite (Istrue_proof_irrelevant _ c1 c2). - auto. -Qed. - - -(* FIXME: redundant with definition in Machblock *) -Definition length_opt {A} (o: option A) : nat := - match o with - | Some o => 1 - | None => 0 - end. - -(* WARNING: the notion of size is not the same than in Machblock ! - We ignore labels here... - The result is in Z to be compatible with operations on PC -*) -Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). -(* match (body b, exit b) with - | (nil, None) => 1 - | _ => - end. - *) - -Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. -Proof. - intros. destruct l; try (contradict H; auto; fail). - simpl. omega. -Qed. - -Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. -Proof. - intros. destruct z; auto. - - contradict H. simpl. apply gt_irrefl. - - apply Zgt_pos_0. - - contradict H. simpl. apply gt_irrefl. -Qed. - -Lemma size_positive (b:bblock): size b > 0. -Proof. - unfold size. destruct b as [hd bdy ex cor]. simpl. - destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). - inversion cor; contradict H; simpl; auto. -(* rewrite eq. (* inversion COR. *) (* inversion H. *) - - assert ((length b > 0)%nat). apply length_nonil. auto. - omega. - - destruct e; simpl; try omega. contradict H; simpl; auto. - *)Qed. - - -Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma no_header_size: - forall bb, size (no_header bb) = size bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. -Qed. - -Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma stick_header_size: - forall h bb, size (stick_header h bb) = size bb. -Proof. - intros. destruct bb. unfold stick_header. simpl. reflexivity. -Qed. - -Lemma stick_header_no_header: - forall bb, stick_header (header bb) (no_header bb) = bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. -Qed. - - -Definition bblocks := list bblock. - -Fixpoint size_blocks (l: bblocks): Z := - match l with - | nil => 0 - | b :: l => - (size b) + (size_blocks l) - end - . - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. - -Inductive instruction : Type := - | PBasic (i: basic) - | PControl (i: control) -. - -Coercion PBasic: basic >-> instruction. -Coercion PControl: control >-> instruction. - -Definition code := list instruction. -Definition bcode := list basic. - -Fixpoint basics_to_code (l: list basic) := - match l with - | nil => nil - | bi::l => (PBasic bi)::(basics_to_code l) - end. - -Fixpoint code_to_basics (c: code) := - match c with - | (PBasic i)::c => - match code_to_basics c with - | None => None - | Some l => Some (i::l) - end - | _::c => None - | nil => Some nil - end. - -Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. -Proof. - intros. induction c as [|i c]; simpl; auto. - rewrite IHc. auto. -Qed. - -Lemma code_to_basics_dist: - forall c c' l l', - code_to_basics c = Some l -> - code_to_basics c' = Some l' -> - code_to_basics (c ++ c') = Some (l ++ l'). -Proof. - induction c as [|i c]; simpl; auto. - - intros. inv H. simpl. auto. - - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. - inv H. erewrite IHc; eauto. auto. -Qed. - -(** - Asmblockgen will have to translate a Mach control into a list of instructions of the form - i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction - These functions provide way to extract the basic / control instructions -*) - -Fixpoint extract_basic (c: code) := - match c with - | nil => nil - | PBasic i :: c => i :: (extract_basic c) - | PControl i :: c => nil - end. - -Fixpoint extract_ctl (c: code) := - match c with - | nil => None - | PBasic i :: c => extract_ctl c - | PControl i :: nil => Some i - | PControl i :: _ => None (* if the first found control instruction isn't the last *) - end. - -(** * Utility for Asmblockgen *) - -Program Definition bblock_single_inst (i: instruction) := - match i with - | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} - | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} - end. -Next Obligation. - apply wf_bblock_refl. constructor. - right. discriminate. - constructor. -Qed. - -(** This definition is not used anymore *) -(* Program Definition bblock_basic_ctl (c: list basic) (i: option control) := - match i with - | Some i => {| header:=nil; body:=c; exit:=Some i |} - | None => - match c with - | _::_ => {| header:=nil; body:=c; exit:=None |} - | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} - end - end. -Next Obligation. - bblock_auto_correct. -Qed. Next Obligation. - bblock_auto_correct. -Qed. *) - - -(** * Operational semantics *) - -(** The semantics operates over a single mapping from registers - (type [preg]) to values. We maintain - the convention that integer registers are mapped to values of - type [Tint] or [Tlong] (in 64 bit mode), - and float registers to values of type [Tsingle] or [Tfloat]. *) - -Definition regset := Pregmap.t val. - -Definition genv := Genv.t fundef unit. - -Notation "a # b" := (a b) (at level 1, only parsing) : asm. -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. - -Open Scope asm. - -(** Undefining some registers *) - -Fixpoint undef_regs (l: list preg) (rs: regset) : regset := - match l with - | nil => rs - | r :: l' => undef_regs l' (rs#r <- Vundef) - end. - - -(** Assigning a register pair *) -Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := - match p with - | One r => rs#r <- v - | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) - end. - -(* TODO: Is it still useful ?? *) - - -(** Assigning multiple registers *) - -(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := - match rl, vl with - | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) - | _, _ => rs - end. - *) -(** Assigning the result of a builtin *) - -Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := - match res with - | BR r => rs#r <- v - | BR_none => rs - | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) - end. +Require Export Asmvliw. Section RELSEM. - -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [Next rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Stuck] if the processor is stuck. *) - -Inductive outcome: Type := - | Next (rs:regset) (m:mem) - | Stuck. -(* Arguments outcome: clear implicits. *) - - -(** ** Arithmetic Expressions (including comparisons) *) - -Inductive signedness: Type := Signed | Unsigned. - -Inductive intsize: Type := Int | Long. - -Definition itest_for_cmp (c: comparison) (s: signedness) := - match c, s with - | Cne, Signed => ITne - | Ceq, Signed => ITeq - | Clt, Signed => ITlt - | Cge, Signed => ITge - | Cle, Signed => ITle - | Cgt, Signed => ITgt - | Cne, Unsigned => ITneu - | Ceq, Unsigned => ITequ - | Clt, Unsigned => ITltu - | Cge, Unsigned => ITgeu - | Cle, Unsigned => ITleu - | Cgt, Unsigned => ITgtu - end. - -Inductive oporder_ftest := - | Normal (ft: ftest) - | Reversed (ft: ftest) -. - -Definition ftest_for_cmp (c: comparison) := - match c with - | Ceq => Normal FToeq - | Cne => Normal FTune - | Clt => Normal FTolt - | Cle => Reversed FToge - | Cgt => Reversed FTolt - | Cge => Normal FToge - end. - -Definition notftest_for_cmp (c: comparison) := - match c with - | Ceq => Normal FTune - | Cne => Normal FToeq - | Clt => Normal FTuge - | Cle => Reversed FTult - | Cgt => Reversed FTuge - | Cge => Normal FTult - end. - -(* CoMPare Signed Words to Zero *) -Definition btest_for_cmpswz (c: comparison) := - match c with - | Cne => BTwnez - | Ceq => BTweqz - | Clt => BTwltz - | Cge => BTwgez - | Cle => BTwlez - | Cgt => BTwgtz - end. - -(* CoMPare Signed Doubles to Zero *) -Definition btest_for_cmpsdz (c: comparison) := - match c with - | Cne => BTdnez - | Ceq => BTdeqz - | Clt => BTdltz - | Cge => BTdgez - | Cle => BTdlez - | Cgt => BTdgtz - end. - -Definition cmp_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTwltz => (Some Clt, Int) - | BTwgez => (Some Cge, Int) - | BTwlez => (Some Cle, Int) - | BTwgtz => (Some Cgt, Int) - - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | BTdltz => (Some Clt, Long) - | BTdgez => (Some Cge, Long) - | BTdlez => (Some Cle, Long) - | BTdgtz => (Some Cgt, Long) - end. - -Definition cmpu_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | _ => (None, Int) - end. - - -(* a few lemma on comparisons of unsigned (e.g. pointers) *) - -Definition Val_cmpu_bool cmp v1 v2: option bool := - Val.cmpu_bool (fun _ _ => true) cmp v1 v2. - -Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmpu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). - -Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) - (Val_cmpu cmp v1 v2). -Proof. - unfold Val.cmpu, Val_cmpu. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob; simpl. - - erewrite Val_cmpu_bool_correct; eauto. - econstructor. - - econstructor. -Qed. - -Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) - := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). - -Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmplu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). - -Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) - (Val_cmplu cmp v1 v2). -Proof. - unfold Val.cmplu, Val_cmplu. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob as [b|]; simpl. - - erewrite Val_cmplu_bool_correct; eauto. - simpl. econstructor. - - econstructor. -Qed. - - -(** Comparing integers *) -Definition compare_int (t: itest) (v1 v2: val): val := - match t with - | ITne => Val.cmp Cne v1 v2 - | ITeq => Val.cmp Ceq v1 v2 - | ITlt => Val.cmp Clt v1 v2 - | ITge => Val.cmp Cge v1 v2 - | ITle => Val.cmp Cle v1 v2 - | ITgt => Val.cmp Cgt v1 v2 - | ITneu => Val_cmpu Cne v1 v2 - | ITequ => Val_cmpu Ceq v1 v2 - | ITltu => Val_cmpu Clt v1 v2 - | 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 := - let res := match t with - | ITne => Val.cmpl Cne v1 v2 - | ITeq => Val.cmpl Ceq v1 v2 - | ITlt => Val.cmpl Clt v1 v2 - | ITge => Val.cmpl Cge v1 v2 - | ITle => Val.cmpl Cle v1 v2 - | ITgt => Val.cmpl Cgt v1 v2 - | ITneu => Some (Val_cmplu Cne v1 v2) - | ITequ => Some (Val_cmplu Ceq v1 v2) - | ITltu => Some (Val_cmplu Clt v1 v2) - | 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 - | None => Vundef - end - . - -Definition compare_single (t: ftest) (v1 v2: val): val := - match t with - | FTone | FTueq => Vundef (* unused *) - | FToeq => Val.cmpfs Ceq v1 v2 - | FTune => Val.cmpfs Cne v1 v2 - | FTolt => Val.cmpfs Clt v1 v2 - | FTuge => Val.notbool (Val.cmpfs Clt v1 v2) - | FToge => Val.cmpfs Cge v1 v2 - | FTult => Val.notbool (Val.cmpfs Cge v1 v2) - end. - -Definition compare_float (t: ftest) (v1 v2: val): val := - match t with - | FTone | FTueq => Vundef (* unused *) - | FToeq => Val.cmpf Ceq v1 v2 - | FTune => Val.cmpf Cne v1 v2 - | FTolt => Val.cmpf Clt v1 v2 - | FTuge => Val.notbool (Val.cmpf Clt v1 v2) - | FToge => Val.cmpf Cge v1 v2 - | FTult => Val.notbool (Val.cmpf Cge v1 v2) - end. - (** Execution of arith instructions *) Variable ge: genv. -Definition arith_eval_r n := - match n with - | Ploadsymbol s ofs => Genv.symbol_address ge s ofs - end -. - -Definition arith_eval_rr n v := - match n with - | Pmv => v - | Pnegw => Val.neg v - | Pnegl => Val.negl v - | Pcvtl2w => Val.loword v - | Psxwd => Val.longofint v - | Pzxwd => Val.longofintu v - | Pfnegd => Val.negf v - | Pfnegw => Val.negfs v - | Pfabsd => Val.absf v - | Pfabsw => Val.absfs v - | Pfnarrowdw => Val.singleoffloat v - | Pfwidenlwd => Val.floatofsingle v - | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end - | Pfloatuwrnsz => match Val.singleofintu v with Some f => f | _ => Vundef end - | Pfloatudrnsz => match Val.floatoflongu v with Some f => f | _ => Vundef end - | Pfloatdrnsz => match Val.floatoflong v with Some f => f | _ => Vundef end - | Pfloatudrnsz_i32 => match Val.floatofintu v with Some f => f | _ => Vundef end - | Pfloatdrnsz_i32 => match Val.floatofint v with Some f => f | _ => Vundef end - | Pfixedwrzz => match Val.intofsingle v with Some i => i | _ => Vundef end - | Pfixeduwrzz => match Val.intuofsingle v with Some i => i | _ => Vundef end - | Pfixeddrzz => match Val.longoffloat v with Some i => i | _ => Vundef end - | Pfixedudrzz => match Val.longuoffloat v with Some i => i | _ => Vundef end - | Pfixeddrzz_i32 => match Val.intoffloat v with Some i => i | _ => Vundef end - | Pfixedudrzz_i32 => match Val.intuoffloat v with Some i => i | _ => Vundef end - end. - -Definition arith_eval_ri32 n i := - match n with - | Pmake => Vint i - end. - -Definition arith_eval_ri64 n i := - match n with - | Pmakel => Vlong i - end. - -Definition arith_eval_rf32 n i := - match n with - | Pmakefs => Vsingle i - end. - -Definition arith_eval_rf64 n i := - match n with - | Pmakef => Vfloat i - end. - -Definition arith_eval_rrr n v1 v2 := - match n with - | Pcompw c => compare_int c v1 v2 - | Pcompl c => compare_long c v1 v2 - | Pfcompw c => compare_single c v1 v2 - | Pfcompl c => compare_float c v1 v2 - - | Paddw => Val.add v1 v2 - | Psubw => Val.sub v1 v2 - | Pmulw => Val.mul v1 v2 - | Pandw => Val.and v1 v2 - | Pnandw => Val.notint (Val.and v1 v2) - | Porw => Val.or v1 v2 - | Pnorw => Val.notint (Val.or v1 v2) - | Pxorw => Val.xor v1 v2 - | Pnxorw => Val.notint (Val.xor v1 v2) - | Pandnw => Val.and (Val.notint v1) v2 - | Pornw => Val.or (Val.notint v1) v2 - | Psrlw => Val.shru v1 v2 - | Psraw => Val.shr v1 v2 - | Psllw => Val.shl v1 v2 - - | Paddl => Val.addl v1 v2 - | Psubl => Val.subl v1 v2 - | Pandl => Val.andl v1 v2 - | Pnandl => Val.notl (Val.andl v1 v2) - | Porl => Val.orl v1 v2 - | Pnorl => Val.notl (Val.orl v1 v2) - | Pxorl => Val.xorl v1 v2 - | Pnxorl => Val.notl (Val.xorl v1 v2) - | Pandnl => Val.andl (Val.notl v1) v2 - | Pornl => Val.orl (Val.notl v1) v2 - | Pmull => Val.mull v1 v2 - | Pslll => Val.shll v1 v2 - | Psrll => Val.shrlu v1 v2 - | Psral => Val.shrl v1 v2 - - | Pfaddd => Val.addf v1 v2 - | Pfaddw => Val.addfs v1 v2 - | Pfsbfd => Val.subf v1 v2 - | Pfsbfw => Val.subfs v1 v2 - | Pfmuld => Val.mulf v1 v2 - | Pfmulw => Val.mulfs 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) - | Pmuliw => Val.mul v (Vint i) - | Pandiw => Val.and v (Vint i) - | Pnandiw => Val.notint (Val.and v (Vint i)) - | Poriw => Val.or v (Vint i) - | Pnoriw => Val.notint (Val.or v (Vint i)) - | Pxoriw => Val.xor v (Vint i) - | Pnxoriw => Val.notint (Val.xor v (Vint i)) - | Pandniw => Val.and (Val.notint v) (Vint i) - | Porniw => Val.or (Val.notint v) (Vint i) - | Psraiw => Val.shr v (Vint i) - | Psrliw => Val.shru v (Vint i) - | Pslliw => Val.shl v (Vint i) - | Proriw => Val.ror v (Vint i) - | Psllil => Val.shll v (Vint i) - | Psrlil => Val.shrlu v (Vint i) - | Psrail => Val.shrl 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) - | Pmulil => Val.mull v (Vlong i) - | Pandil => Val.andl v (Vlong i) - | Pnandil => Val.notl (Val.andl v (Vlong i)) - | Poril => Val.orl v (Vlong i) - | Pnoril => Val.notl (Val.orl v (Vlong i)) - | Pxoril => Val.xorl v (Vlong 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) - 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) - end. - -Definition arith_eval_arri32 n v1 v2 v3 := - match n with - | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) - end. - -Definition arith_eval_arri64 n v1 v2 v3 := - match n with - | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) - end. Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := match ai with - | PArithR n d => rs#d <- (arith_eval_r n) + | PArithR n d => rs#d <- (arith_eval_r ge n) | PArithRR n d s => rs#d <- (arith_eval_rr n rs#s) @@ -1252,18 +68,9 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := (** Auxiliaries for memory accesses *) -Definition eval_offset (ofs: offset) : res ptrofs := - match ofs with - | Ofsimm n => OK n - | Ofslow id delta => - match (Genv.symbol_address ge id delta) with - | Vptr b ofs => OK ofs - | _ => Error (msg "Asmblock.eval_offset") - end - end. Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := - match (eval_offset ofs) with + match (eval_offset ge ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with | None => Stuck | Some v => Next (rs#d <- v) m @@ -1278,7 +85,7 @@ Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ir end. Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := - match (eval_offset ofs) with + match (eval_offset ge ofs) with | OK ptr => match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with | None => Stuck | Some m' => Next rs m' @@ -1292,31 +99,7 @@ Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: i | Some m' => Next rs m' end. -Definition load_chunk n := - match n with - | Plb => Mint8signed - | Plbu => Mint8unsigned - | Plh => Mint16signed - | Plhu => Mint16unsigned - | Plw => Mint32 - | Plw_a => Many32 - | Pld => Mint64 - | Pld_a => Many64 - | Pfls => Mfloat32 - | Pfld => Mfloat64 - end. -Definition store_chunk n := - match n with - | Psb => Mint8unsigned - | Psh => Mint16unsigned - | Psw => Mint32 - | Psw_a => Many32 - | Psd => Mint64 - | Psd_a => Many64 - | Pfss => Mfloat32 - | Pfsd => Mfloat64 - end. (** * basic instructions *) @@ -1374,55 +157,11 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextblock]) or branching to a label ([goto_label]). *) - -Definition nextblock (b:bblock) (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). - -(** Looking up bblocks in a code sequence by position. *) -Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := - match lb with - | nil => None - | b :: il => - if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) - else if zeq pos 0 then Some b - else find_bblock (pos - (size b)) il - end. (** Position corresponding to a label *) -(** TODO: redundant w.r.t Machblock *) -Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. -Proof. - apply List.in_dec. - apply Pos.eq_dec. -Qed. - - -(** Note: copy-paste from Machblock *) -Definition is_label (lbl: label) (bb: bblock) : bool := - if in_dec lbl (header bb) then true else false. - -Lemma is_label_correct_true lbl bb: - List.In lbl (header bb) <-> is_label lbl bb = true. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. -Lemma is_label_correct_false lbl bb: - ~(List.In lbl (header bb)) <-> is_label lbl bb = false. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - -(** convert a label into a position in the code *) -Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := - match lb with - | nil => None - | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' - end. Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := match label_pos lbl 0 (fn_blocks f) with @@ -1525,67 +264,13 @@ Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcom register is reserved as temporary, to be used by the generated RV32G code. *) - (* FIXME - R16 and R32 are excluded *) -Definition preg_of (r: mreg) : preg := - match r with - | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 - | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) - | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 - | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 - | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 - | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 - | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 - | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 - | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 - | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 - | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 - end. -(** Undefine all registers except SP and callee-save registers *) - -Definition undef_caller_save_regs (rs: regset) : regset := - fun r => - if preg_eq r SP - || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) - then rs r - else Vundef. - - -(** Extract the values of the arguments of an external call. - We exploit the calling conventions from module [Conventions], except that - we use RISC-V registers instead of locations. *) - -Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := - | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (preg_of r)) - | extcall_arg_stack: forall ofs ty bofs v, - bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> - Mem.loadv (chunk_of_type ty) m - (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> - extcall_arg rs m (S Outgoing ofs ty) v. - -Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := - | extcall_arg_one: forall l v, - extcall_arg rs m l v -> - extcall_arg_pair rs m (One l) v - | extcall_arg_twolong: forall hi lo vhi vlo, - extcall_arg rs m hi vhi -> - extcall_arg rs m lo vlo -> - extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. - -Definition loc_external_result (sg: signature) : rpair preg := - map_rpair preg_of (loc_result sg). -(** Execution of the instruction at [rs PC]. *) -Inductive state: Type := - | State: regset -> mem -> state. + + + +(** Execution of the instruction at [rs PC]. *) (** TODO @@ -1628,24 +313,7 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. -(** Execution of whole programs. *) - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall m0, - let ge := Genv.globalenv p in - let rs0 := - (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # SP <- Vnullptr - # RA <- Vnullptr in - Genv.init_mem p = Some m0 -> - initial_state p (State rs0 m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r, - rs PC = Vnullptr -> - rs GPR0 = Vint r -> - final_state (State rs m) r. + Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 92630772..32e5e5bb 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -633,7 +633,7 @@ Fixpoint trans_body (b: list basic) : list L.inst := Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (PReg(#PC) @ Enil)) :: k. -Definition trans_block (b: Asmblock.bblock) : L.bblock := +Definition trans_block (b: Asmvliw.bblock) : L.bblock := trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. @@ -649,7 +649,7 @@ Qed. Definition state := L.mem. Definition exec := L.run. -Definition match_states (s: Asmblock.state) (s': state) := +Definition match_states (s: Asmvliw.state) (s': state) := let (rs, m) := s in s' pmem = Memstate m /\ forall r, s' (#r) = Val (rs r). @@ -662,7 +662,7 @@ Definition match_outcome (o:outcome) (s: option state) := Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). -Definition trans_state (s: Asmblock.state) : state := +Definition trans_state (s: Asmvliw.state) : state := let (rs, m) := s in fun x => if (Pos.eq_dec x pmem) then Memstate m else match (inv_ppos x) with @@ -1537,7 +1537,7 @@ Definition string_of_op (op: P.op): ?? pstring := | Fail => RET (Str "Fail") end. -Definition bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := +Definition bblock_eq_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) else @@ -1556,7 +1556,7 @@ Hint Resolve bblock_eq_test_correct: wlp. Import UnsafeImpure. -Definition pure_bblock_eq_test (verb: bool) (p1 p2: Asmblock.bblock): bool := unsafe_coerce (bblock_eq_test verb p1 p2). +Definition pure_bblock_eq_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_eq_test verb p1 p2). Theorem pure_bblock_eq_test_correct verb p1 p2: forall ge fn, Ge = Genv ge fn -> @@ -1566,7 +1566,7 @@ Proof. apply unsafe_coerce_not_really_correct; eauto. Qed. -Definition bblock_equivb: Asmblock.bblock -> Asmblock.bblock -> bool := pure_bblock_eq_test true. +Definition bblock_equivb: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_eq_test true. Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. @@ -1576,7 +1576,7 @@ End SECT. Module PChk := ParallelChecks L PosPseudoRegSet. -Definition bblock_para_check (p: Asmblock.bblock) : bool := +Definition bblock_para_check (p: Asmvliw.bblock) : bool := PChk.is_parallelizable (trans_block p). Require Import Asmvliw Permutation. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 3260312d..7cd02540 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1024,14 +1024,14 @@ Definition transl_function (f: Machblock.function) := Pget GPRA RA ::b storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb)). -Definition transf_function (f: Machblock.function) : res Asmblock.function := +Definition transf_function (f: Machblock.function) : res Asmvliw.function := do tf <- transl_function f; if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) then Error (msg "code size exceeded") else OK tf. -Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := +Definition transf_fundef (f: Machblock.fundef) : res Asmvliw.fundef := transf_partial_fundef transf_function f. -Definition transf_program (p: Machblock.program) : res Asmblock.program := +Definition transf_program (p: Machblock.program) : res Asmvliw.program := transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 70f188ec..a071a9f8 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -19,9 +19,9 @@ Require Import Op Locations Machblock Conventions Asmblock. Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. Module MB := Machblock. -Module AB := Asmblock. +Module AB := Asmvliw. -Definition match_prog (p: Machblock.program) (tp: Asmblock.program) := +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: @@ -33,7 +33,7 @@ Qed. Section PRESERVATION. Variable prog: Machblock.program. -Variable tprog: Asmblock.program. +Variable tprog: Asmvliw.program. Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -318,7 +318,7 @@ Proof. exploit preg_of_injective; eauto. intros; subst r; discriminate. Qed. -Inductive match_states: Machblock.state -> Asmblock.state -> Prop := +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) @@ -328,7 +328,7 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (AG: agree ms sp rs) (DXP: ep = true -> rs#FP = parent_sp s), match_states (Machblock.State s fb sp c ms m) - (Asmblock.State rs m') + (Asmvliw.State rs m') | match_states_call: forall s fb ms m m' rs (STACKS: match_stack ge s) @@ -337,7 +337,7 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (ATPC: rs PC = Vptr fb Ptrofs.zero) (ATLR: rs RA = parent_ra s), match_states (Machblock.Callstate s fb ms m) - (Asmblock.State rs m') + (Asmvliw.State rs m') | match_states_return: forall s ms m m' rs (STACKS: match_stack ge s) @@ -345,7 +345,7 @@ Inductive match_states: Machblock.state -> Asmblock.state -> Prop := (AG: agree ms (parent_sp s) rs) (ATPC: rs PC = parent_ra s), match_states (Machblock.Returnstate s ms m) - (Asmblock.State rs m'). + (Asmvliw.State rs m'). Record codestate := Codestate { pstate: state; @@ -373,7 +373,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (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 := (Asmblock.State rs0 m0); + {| pstate := (Asmvliw.State rs0 m0); pheader := (MB.header bb); pbody1 := tbc; pbody2 := (extract_basic tbi); @@ -384,7 +384,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := |} . -Inductive match_asmstate fb: codestate -> Asmblock.state -> Prop := +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)) @@ -394,7 +394,7 @@ Inductive match_asmstate fb: codestate -> Asmblock.state -> Prop := (* (HDROK: header tbb = lhd) *) , match_asmstate fb - {| pstate := (Asmblock.State rs m); + {| pstate := (Asmvliw.State rs m); pheader := lhd; pbody1 := tbdy; pbody2 := extract_basic tex; @@ -402,7 +402,7 @@ Inductive match_asmstate fb: codestate -> Asmblock.state -> Prop := fpok := ep; rem := tc; cur := Some tbb |} - (Asmblock.State rs m) + (Asmvliw.State rs m) . Ltac exploreInst := @@ -716,11 +716,11 @@ Theorem step_simu_control: 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 = (Asmblock.State rs2 m2) -> + 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 (Asmblock.State rs1 m1) -> + 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 @@ -1775,7 +1775,7 @@ Definition return_address_offset : Machblock.function -> Machblock.code -> ptrof Asmblockgenproof0.return_address_offset. Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (AB.semantics tprog). + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). Proof. eapply forward_simulation_star with (measure := measure). - apply senv_preserved. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index a9f17f33..6310b8ae 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -41,7 +41,7 @@ let wordsize = if Archi.ptr64 then 8 else 4 let align n a = (n + a - 1) land (-a) -let stack_pointer = Asmblock.GPR12 +let stack_pointer = Asmvliw.GPR12 (* Emit instruction sequences that set or offset a register by a constant. *) (* @@ -49,7 +49,7 @@ let stack_pointer = Asmblock.GPR12 List.iter emit (Asmgen.loadimm32 dst n []) *) let expand_addptrofs dst src n = - List.iter emit (basic_to_instruction (Asmblock.PArith (Asmblockgen.addptrofs dst src n)) :: []) + List.iter emit (basic_to_instruction (Asmvliw.PArith (Asmblockgen.addptrofs dst src n)) :: []) let expand_storeind_ptr src base ofs = List.iter emit (basic_to_instruction (Asmblockgen.storeind_ptr src base ofs) :: []) let expand_loadind_ptr dst base ofs = @@ -65,7 +65,7 @@ let expand_loadind_ptr dst base ofs = (* Fix-up code around calls to variadic functions. Floating-point arguments residing in FP registers need to be moved to integer registers. *) -let int_param_regs = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11 |] +let int_param_regs = let open Asmvliw in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11 |] (* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) let float_param_regs = [| |] @@ -131,7 +131,7 @@ let emit_move dst r = (* FIXME DMonniaux this is probably not complete *) let get_builtin_arg dst arg = match arg with - | BA (Asmblock.IR reg) -> emit_move dst reg + | BA (Asmvliw.IR reg) -> emit_move dst reg | BA (ireg) -> failwith "get_builtin_arg: BA_int(not ireg)" | BA_int _ -> failwith "get_builtin_arg: BA_int" | BA_long _ -> failwith "get_builtin_arg: BA_long" @@ -147,9 +147,9 @@ let get_builtin_arg dst arg = (* FIXME DMonniaux this is really suboptimal (byte per byte) *) let expand_builtin_memcpy_big sz al src dst = assert (sz > Z.zero); - let dstptr = Asmblock.GPR62 - and srcptr = Asmblock.GPR63 - and tmpbuf = Asmblock.GPR61 in + let dstptr = Asmvliw.GPR62 + and srcptr = Asmvliw.GPR63 + and tmpbuf = Asmvliw.GPR61 in get_builtin_arg dstptr dst; get_builtin_arg srcptr src; emit (Pmake (tmpbuf, sz)); @@ -157,10 +157,10 @@ 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 (Asmblock.Ofsimm Z.zero))); + emit (Plb (tmpbuf, srcptr, AOff (Asmvliw.Ofsimm Z.zero))); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; - emit (Psb (tmpbuf, dstptr, AOff (Asmblock.Ofsimm Z.zero))); + emit (Psb (tmpbuf, dstptr, AOff (Asmvliw.Ofsimm Z.zero))); emit (Paddil (dstptr, dstptr, Z.one)); emit Psemi; emit (Plabel lbl);; @@ -175,41 +175,41 @@ let expand_builtin_memcpy sz al args = (* FIXME probably need to check for size of displacement *) let expand_builtin_vload_common chunk base ofs res = match chunk, res with - | Mint8unsigned, BR(Asmblock.IR res) -> - emit (Plbu (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint8signed, BR(Asmblock.IR res) -> - emit (Plb (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint16unsigned, BR(Asmblock.IR res) -> - emit (Plhu (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint16signed, BR(Asmblock.IR res) -> - emit (Plh (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint32, BR(Asmblock.IR res) -> - emit (Plw (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint64, BR(Asmblock.IR res) -> - emit (Pld (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mint64, BR_splitlong(BR(Asmblock.IR res1), BR(Asmblock.IR res2)) -> + | Mint8unsigned, BR(Asmvliw.IR res) -> + emit (Plbu (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint8signed, BR(Asmvliw.IR res) -> + emit (Plb (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint16unsigned, BR(Asmvliw.IR res) -> + emit (Plhu (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint16signed, BR(Asmvliw.IR res) -> + emit (Plh (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint32, BR(Asmvliw.IR res) -> + emit (Plw (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint64, BR(Asmvliw.IR res) -> + emit (Pld (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> let ofs' = Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, AOff (Asmblock.Ofsimm ofs))); - emit (Plw (res1, base, AOff (Asmblock.Ofsimm ofs'))) + emit (Plw (res2, base, AOff (Asmvliw.Ofsimm ofs))); + emit (Plw (res1, base, AOff (Asmvliw.Ofsimm ofs'))) end else begin - emit (Plw (res1, base, AOff (Asmblock.Ofsimm ofs'))); - emit (Plw (res2, base, AOff (Asmblock.Ofsimm ofs))) + emit (Plw (res1, base, AOff (Asmvliw.Ofsimm ofs'))); + emit (Plw (res2, base, AOff (Asmvliw.Ofsimm ofs))) end - | Mfloat32, BR(Asmblock.IR res) -> - emit (Pfls (res, base, AOff (Asmblock.Ofsimm ofs))) - | Mfloat64, BR(Asmblock.IR res) -> - emit (Pfld (res, base, AOff (Asmblock.Ofsimm ofs))) + | Mfloat32, BR(Asmvliw.IR res) -> + emit (Pfls (res, base, AOff (Asmvliw.Ofsimm ofs))) + | Mfloat64, BR(Asmvliw.IR res) -> + emit (Pfld (res, base, AOff (Asmvliw.Ofsimm ofs))) | _ -> assert false let expand_builtin_vload chunk args res = match args with - | [BA(Asmblock.IR addr)] -> + | [BA(Asmvliw.IR addr)] -> expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> expand_builtin_vload_common chunk stack_pointer ofs res - | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs))] -> + | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs))] -> expand_builtin_vload_common chunk addr ofs res | _ -> assert false @@ -217,32 +217,32 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk base ofs src = match chunk, src with - | (Mint8signed | Mint8unsigned), BA(Asmblock.IR src) -> - emit (Psb (src, base, AOff (Asmblock.Ofsimm ofs))) - | (Mint16signed | Mint16unsigned), BA(Asmblock.IR src) -> - emit (Psh (src, base, AOff (Asmblock.Ofsimm ofs))) - | Mint32, BA(Asmblock.IR src) -> - emit (Psw (src, base, AOff (Asmblock.Ofsimm ofs))) - | Mint64, BA(Asmblock.IR src) -> - emit (Psd (src, base, AOff (Asmblock.Ofsimm ofs))) - | Mint64, BA_splitlong(BA(Asmblock.IR src1), BA(Asmblock.IR src2)) -> + | (Mint8signed | Mint8unsigned), BA(Asmvliw.IR src) -> + emit (Psb (src, base, AOff (Asmvliw.Ofsimm ofs))) + | (Mint16signed | Mint16unsigned), BA(Asmvliw.IR src) -> + emit (Psh (src, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint32, BA(Asmvliw.IR src) -> + emit (Psw (src, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint64, BA(Asmvliw.IR src) -> + emit (Psd (src, base, AOff (Asmvliw.Ofsimm ofs))) + | Mint64, BA_splitlong(BA(Asmvliw.IR src1), BA(Asmvliw.IR src2)) -> let ofs' = Ptrofs.add ofs _4 in - emit (Psw (src2, base, AOff (Asmblock.Ofsimm ofs))); - emit (Psw (src1, base, AOff (Asmblock.Ofsimm ofs'))) - | Mfloat32, BA(Asmblock.IR src) -> - emit (Pfss (src, base, AOff (Asmblock.Ofsimm ofs))) - | Mfloat64, BA(Asmblock.IR src) -> - emit (Pfsd (src, base, AOff (Asmblock.Ofsimm ofs))) + emit (Psw (src2, base, AOff (Asmvliw.Ofsimm ofs))); + emit (Psw (src1, base, AOff (Asmvliw.Ofsimm ofs'))) + | Mfloat32, BA(Asmvliw.IR src) -> + emit (Pfss (src, base, AOff (Asmvliw.Ofsimm ofs))) + | Mfloat64, BA(Asmvliw.IR src) -> + emit (Pfsd (src, base, AOff (Asmvliw.Ofsimm ofs))) | _ -> assert false let expand_builtin_vstore chunk args = match args with - | [BA(Asmblock.IR addr); src] -> + | [BA(Asmvliw.IR addr); src] -> expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> expand_builtin_vstore_common chunk stack_pointer ofs src - | [BA_addptr(BA(Asmblock.IR addr), (BA_int ofs | BA_long ofs)); src] -> + | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs)); src] -> expand_builtin_vstore_common chunk addr ofs src | _ -> assert false @@ -265,7 +265,7 @@ let arguments_size sg = let _nbregargs_ = 12 let _alignment_ = 8 -let save_arguments first_reg base_ofs = let open Asmblock in +let save_arguments first_reg base_ofs = let open Asmvliw in for i = first_reg to (_nbregargs_ - 1) do begin expand_storeind_ptr int_param_regs.(i) @@ -281,9 +281,9 @@ match !vararg_start_ofs with | None -> invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> - expand_addptrofs Asmblock.GPR32 stack_pointer (Ptrofs.repr ofs); + expand_addptrofs Asmvliw.GPR32 stack_pointer (Ptrofs.repr ofs); emit Psemi; - expand_storeind_ptr Asmblock.GPR32 r Ptrofs.zero + expand_storeind_ptr Asmvliw.GPR32 r Ptrofs.zero (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to two instructions, one computing the low 32 bits of the result, @@ -348,7 +348,7 @@ let expand_bswap64 d s = assert false (* Handling of compiler-inlined builtins *) -let expand_builtin_inline name args res = let open Asmblock in +let expand_builtin_inline name args res = let open Asmvliw in match name, args, res with (* Synchronization *) | "__builtin_membar", [], _ -> @@ -376,14 +376,14 @@ let expand_instruction instr = match instr with | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in - emit (Pmv (Asmblock.GPR17, stack_pointer)); + emit (Pmv (Asmvliw.GPR17, stack_pointer)); if sg.sig_cc.cc_vararg then begin let n = arguments_size sg in let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); emit Psemi; - expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; + expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; emit Psemi; let va_ofs = sz in @@ -393,7 +393,7 @@ let expand_instruction instr = end else begin expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); emit Psemi; - expand_storeind_ptr Asmblock.GPR17 stack_pointer ofs; + expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; emit Psemi; vararg_start_ofs := None end @@ -476,7 +476,7 @@ let expand_instruction instr = (* NOTE: Dwarf register maps for RV32G are not yet specified officially. This is just a placeholder. *) -let int_reg_to_dwarf = let open Asmblock in function +let int_reg_to_dwarf = let open Asmvliw in function | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 @@ -491,7 +491,7 @@ let int_reg_to_dwarf = let open Asmblock in function | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 -let preg_to_dwarf = let open Asmblock in function +let preg_to_dwarf = let open Asmvliw in function | IR r -> int_reg_to_dwarf r | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) | _ -> assert false diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c15a33af..d56a7a84 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -31,9 +31,814 @@ Require Import Locations. Require Stacklayout. Require Import Conventions. Require Import Errors. -Require Export Asmblock. Require Import Sorting.Permutation. +(** * Abstract syntax *) + +(** General Purpose registers. +*) + +Inductive gpreg: Type := + | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg + | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. + +Definition ireg := gpreg. +Definition freg := gpreg. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** 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 + | PC: preg + . + +Coercion IR: gpreg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) + +Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'FP'" := GPR17 (only parsing) : asm. +Notation "'MFP'" := R17 (only parsing) : asm. +Notation "'GPRA'" := GPR16 (only parsing) : asm. +Notation "'RTMP'" := GPR32 (only parsing) : asm. + +Inductive btest: Type := + | BTdnez (**r Double Not Equal to Zero *) + | BTdeqz (**r Double Equal to Zero *) + | BTdltz (**r Double Less Than Zero *) + | 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 *) + | BTweqz (**r Word Equal to Zero *) + | BTwltz (**r Word Less Than Zero *) + | BTwgez (**r Word Greater Than or Equal to Zero *) + | BTwlez (**r Word Less Than or Equal to Zero *) + | BTwgtz (**r Word Greater Than Zero *) + . + +Inductive itest: Type := + | ITne (**r Not Equal *) + | ITeq (**r Equal *) + | ITlt (**r Less Than *) + | ITge (**r Greater Than or Equal *) + | ITle (**r Less Than or Equal *) + | ITgt (**r Greater Than *) + | ITneu (**r Unsigned Not Equal *) + | ITequ (**r Unsigned Equal *) + | ITltu (**r Less Than Unsigned *) + | 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 := + | FTone (**r Ordered and Not Equal *) + | FTueq (**r Unordered or Equal *) + | FToeq (**r Ordered and Equal *) + | FTune (**r Unordered or Not Equal *) + | FTolt (**r Ordered and Less Than *) + | FTuge (**r Unordered or Greater Than or Equal *) + | FToge (**r Ordered and Greater Than or Equal *) + | FTult (**r Unordered or Less Than *) + . + +(** Offsets for load and store instructions. An offset is either an + immediate integer or the low part of a symbol. *) + +Inductive offset : Type := + | Ofsimm (ofs: ptrofs) + | Ofslow (id: ident) (ofs: ptrofs). + +(** We model a subset of the K1c instruction set. In particular, we do not + support floats yet. + + Although it is possible to use the 32-bits mode, for now we don't support it. + + We follow a design close to the one used for the Risc-V port: one set of + pseudo-instructions for 32-bit integer arithmetic, with suffix W, another + set for 64-bit integer arithmetic, with suffix L. + + When mapping to actual instructions, the OCaml code in TargetPrinter.ml + throws an error if we are not in 64-bits mode. +*) + +(** * Instructions *) + +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 +*) +Inductive ex_instruction : Type := + (* Pseudo-instructions *) +(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) + + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) +. + +(** FIXME: comment not up to date ! + + + The pseudo-instructions are the following: + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. +*) + +(** Control Flow instructions *) +Inductive cf_instruction : Type := + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (r: ireg) (**r function call on register value *) + | Pjumptable (r: ireg) (labels: list label) (**r N-way branch through a jump table (pseudo) *) + + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (r: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + + (* Conditional branches *) + | 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 *) +. + +(** Loads **) +Inductive load_name : Type := + | Plb (**r load byte *) + | Plbu (**r load byte unsigned *) + | Plh (**r load half word *) + | Plhu (**r load half word unsigned *) + | Plw (**r load int32 *) + | Plw_a (**r load any32 *) + | Pld (**r load int64 *) + | Pld_a (**r load any64 *) + | Pfls (**r load float *) + | Pfld (**r load 64-bit float *) +. + +Inductive ld_instruction : Type := + | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) +. + +Coercion PLoadRRO: load_name >-> Funclass. +Coercion PLoadRRR: load_name >-> Funclass. + +(** Stores **) +Inductive store_name : Type := + | Psb (**r store byte *) + | Psh (**r store half byte *) + | Psw (**r store int32 *) + | Psw_a (**r store any32 *) + | Psd (**r store int64 *) + | Psd_a (**r store any64 *) + | Pfss (**r store float *) + | Pfsd (**r store 64-bit float *) +. + +Inductive st_instruction : Type := + | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) + | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) +. + +Coercion PStoreRRO: store_name >-> Funclass. +Coercion PStoreRRR: store_name >-> Funclass. + +(** Arithmetic instructions **) +Inductive arith_name_r : Type := + | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) +. + +Inductive arith_name_rr : Type := + | Pmv (**r register move *) + | Pnegw (**r negate word *) + | Pnegl (**r negate long *) + | Pcvtl2w (**r Convert Long to Word *) + | Psxwd (**r Sign Extend Word to Double Word *) + | Pzxwd (**r Zero Extend Word to Double Word *) + + | Pfabsd (**r float absolute double *) + | Pfabsw (**r float absolute word *) + | Pfnegd (**r float negate double *) + | Pfnegw (**r float negate 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) *) + | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) + | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) + | Pfloatudrnsz_i32 (**r Floating Point Conversion from integer (unsigned int -> float) *) + | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) + | Pfloatdrnsz_i32 (**r Floating Point Conversion from integer (int -> float) *) + | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) + | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) + | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) + | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) + | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) + | Pfixedudrzz_i32 (**r Integer conversion from floating point (float -> unsigned int) *) +. + +Inductive arith_name_ri32 : Type := + | Pmake (**r load immediate *) +. + +Inductive arith_name_ri64 : Type := + | Pmakel (**r load immediate long *) +. + +Inductive arith_name_rf32 : Type := + | Pmakefs (**r load immediate single *) +. + +Inductive arith_name_rf64 : Type := + | Pmakef (**r load immediate float *) +. + +Inductive arith_name_rrr : Type := + | Pcompw (it: itest) (**r comparison word *) + | Pcompl (it: itest) (**r comparison long *) + | Pfcompw (ft: ftest) (**r comparison float32 *) + | Pfcompl (ft: ftest) (**r comparison float64 *) + + | Paddw (**r add word *) + | Psubw (**r sub word *) + | Pmulw (**r mul word *) + | Pandw (**r and word *) + | Pnandw (**r nand word *) + | Porw (**r or word *) + | Pnorw (**r nor word *) + | Pxorw (**r xor word *) + | Pnxorw (**r nxor word *) + | Pandnw (**r andn word *) + | Pornw (**r orn word *) + | Psraw (**r shift right arithmetic word *) + | Psrlw (**r shift right logical word *) + | Psllw (**r shift left logical word *) + + | Paddl (**r add long *) + | Psubl (**r sub long *) + | Pandl (**r and long *) + | Pnandl (**r nand long *) + | Porl (**r or long *) + | Pnorl (**r nor long *) + | Pxorl (**r xor long *) + | Pnxorl (**r nxor long *) + | Pandnl (**r andn long *) + | Pornl (**r orn long *) + | Pmull (**r mul long (low part) *) + | Pslll (**r shift left logical long *) + | Psrll (**r shift right logical long *) + | Psral (**r shift right arithmetic long *) + + | Pfaddd (**r float add double *) + | Pfaddw (**r float add word *) + | Pfsbfd (**r float sub double *) + | Pfsbfw (**r float sub word *) + | Pfmuld (**r float multiply double *) + | Pfmulw (**r float multiply word *) +. + +Inductive arith_name_rri32 : Type := + | Pcompiw (it: itest) (**r comparison imm word *) + + | Paddiw (**r add imm word *) + | Pmuliw (**r add imm word *) + | Pandiw (**r and imm word *) + | Pnandiw (**r nand imm word *) + | Poriw (**r or imm word *) + | Pnoriw (**r nor imm word *) + | Pxoriw (**r xor imm word *) + | Pnxoriw (**r nxor imm word *) + | Pandniw (**r andn word *) + | Porniw (**r orn word *) + | Psraiw (**r shift right arithmetic imm word *) + | Psrliw (**r shift right logical imm word *) + | Pslliw (**r shift left logical imm word *) + | Proriw (**r rotate right imm word *) + | Psllil (**r shift left logical immediate long *) + | Psrlil (**r shift right logical immediate long *) + | Psrail (**r shift right arithmetic immediate long *) +. + +Inductive arith_name_rri64 : Type := + | Pcompil (it: itest) (**r comparison imm long *) + | Paddil (**r add immediate long *) + | Pmulil (**r mul immediate long *) + | Pandil (**r and immediate long *) + | Pnandil (**r nand immediate long *) + | Poril (**r or immediate long *) + | Pnoril (**r nor immediate long *) + | Pxoril (**r xor immediate long *) + | Pnxoril (**r nxor immediate long *) + | Pandnil (**r andn immediate long *) + | Pornil (**r orn immediate long *) +. + +Inductive arith_name_arrr : Type := + | Pmaddw (**r multiply add word *) + | Pmaddl (**r multiply add long *) +. + +Inductive arith_name_arri32 : Type := + | Pmaddiw (**r multiply add word *) +. + +Inductive arith_name_arri64 : Type := + | Pmaddil (**r multiply add long *) +. + +Inductive ar_instruction : Type := + | PArithR (i: arith_name_r) (rd: ireg) + | PArithRR (i: arith_name_rr) (rd rs: ireg) + | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) + | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRF32 (i: arith_name_rf32) (rd: ireg) (imm: float32) + | PArithRF64 (i: arith_name_rf64) (rd: ireg) (imm: float) + | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) + | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) + | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) + | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) + | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) + | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) +. + +Coercion PArithR: arith_name_r >-> Funclass. +Coercion PArithRR: arith_name_rr >-> Funclass. +Coercion PArithRI32: arith_name_ri32 >-> Funclass. +Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRF32: arith_name_rf32 >-> Funclass. +Coercion PArithRF64: arith_name_rf64 >-> Funclass. +Coercion PArithRRR: arith_name_rrr >-> Funclass. +Coercion PArithRRI32: arith_name_rri32 >-> Funclass. +Coercion PArithRRI64: arith_name_rri64 >-> Funclass. +Coercion PArithARRR: arith_name_arrr >-> Funclass. +Coercion PArithARRI32: arith_name_arri32 >-> Funclass. +Coercion PArithARRI64: arith_name_arri64 >-> Funclass. + +Inductive basic : Type := + | PArith (i: ar_instruction) + | PLoad (i: ld_instruction) + | PStore (i: st_instruction) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pnop (**r virtual instruction that does nothing *) +. + +Coercion PLoad: ld_instruction >-> basic. +Coercion PStore: st_instruction >-> basic. +Coercion PArith: ar_instruction >-> basic. + + +Inductive control : Type := + | PExpand (i: ex_instruction) + | PCtlFlow (i: cf_instruction) +. + +Coercion PExpand: ex_instruction >-> control. +Coercion PCtlFlow: cf_instruction >-> control. + + +(** * Definition of a bblock *) + +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. + +Definition non_empty_bblock (body: list basic) (exit: option control): Prop + := body <> nil \/ exit <> None. + +Definition non_empty_body (body: list basic): bool := + match body with + | nil => false + | _ => true + end. + +Definition non_empty_exit (exit: option control): bool := + match exit with + | None => false + | _ => true + end. + +Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. + +Lemma non_empty_bblock_refl: + forall body exit, + non_empty_bblock body exit <-> + Is_true (non_empty_bblockb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. intros. inversion H; contradiction. + - destruct body; destruct exit. + all: simpl; auto. + all: intros; try (right; discriminate); try (left; discriminate). + contradiction. +Qed. + +Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, + exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. + +Definition builtin_aloneb (body: list basic) (exit: option control) := + match exit with + | Some (PExpand (Pbuiltin _ _ _)) => + match body with + | nil => true + | _ => false + end + | _ => true + end. + +Lemma builtin_alone_refl: + forall body exit, + builtin_alone body exit <-> Is_true (builtin_aloneb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. + all: exploreInst; simpl; auto. + unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. + assert (b :: body = nil). eapply H; eauto. discriminate. + - destruct body; destruct exit. + all: simpl; auto; try constructor. + + exploreInst; try discriminate. + simpl. contradiction. + + intros. discriminate. +Qed. + +Definition wf_bblockb (body: list basic) (exit: option control) := + (non_empty_bblockb body exit) && (builtin_aloneb body exit). + +Definition wf_bblock (body: list basic) (exit: option control) := + non_empty_bblock body exit /\ builtin_alone body exit. + +Lemma wf_bblock_refl: + forall body exit, + wf_bblock body exit <-> Is_true (wf_bblockb body exit). +Proof. + intros. split. + - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + apply andb_prop_intro. auto. + - intros. apply andb_prop_elim in H. inv H. + apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + unfold wf_bblock. split; auto. +Qed. + +(** A bblock is well-formed if he contains at least one instruction, + and if there is a builtin then it must be alone in this bblock. *) + +Record bblock := mk_bblock { + header: list label; + body: list basic; + exit: option control; + correct: Is_true (wf_bblockb body exit) +}. + +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. + destruct b; simpl; auto. + - destruct p1, p2; auto. + - destruct p1. +Qed. + +Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +Proof. + destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. + intros; subst. + rewrite (Istrue_proof_irrelevant _ c1 c2). + auto. +Qed. + + +(* FIXME: redundant with definition in Machblock *) +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +(* WARNING: the notion of size is not the same than in Machblock ! + We ignore labels here... + The result is in Z to be compatible with operations on PC +*) +Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). +(* match (body b, exit b) with + | (nil, None) => 1 + | _ => + end. + *) + +Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. +Proof. + intros. destruct l; try (contradict H; auto; fail). + simpl. omega. +Qed. + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. simpl. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. simpl. apply gt_irrefl. +Qed. + +Lemma size_positive (b:bblock): size b > 0. +Proof. + unfold size. destruct b as [hd bdy ex cor]. simpl. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). + inversion cor; contradict H; simpl; auto. +(* rewrite eq. (* inversion COR. *) (* inversion H. *) + - assert ((length b > 0)%nat). apply length_nonil. auto. + omega. + - destruct e; simpl; try omega. contradict H; simpl; auto. + *)Qed. + + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. +Qed. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. +Qed. + + +Definition bblocks := list bblock. + +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control) +. + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. + +Definition code := list instruction. +Definition bcode := list basic. + +Fixpoint basics_to_code (l: list basic) := + match l with + | nil => nil + | bi::l => (PBasic bi)::(basics_to_code l) + end. + +Fixpoint code_to_basics (c: code) := + match c with + | (PBasic i)::c => + match code_to_basics c with + | None => None + | Some l => Some (i::l) + end + | _::c => None + | nil => Some nil + end. + +Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. +Proof. + intros. induction c as [|i c]; simpl; auto. + rewrite IHc. auto. +Qed. + +Lemma code_to_basics_dist: + forall c c' l l', + code_to_basics c = Some l -> + code_to_basics c' = Some l' -> + code_to_basics (c ++ c') = Some (l ++ l'). +Proof. + induction c as [|i c]; simpl; auto. + - intros. inv H. simpl. auto. + - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. + inv H. erewrite IHc; eauto. auto. +Qed. + +(** + Asmblockgen will have to translate a Mach control into a list of instructions of the form + i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction + These functions provide way to extract the basic / control instructions +*) + +Fixpoint extract_basic (c: code) := + match c with + | nil => nil + | PBasic i :: c => i :: (extract_basic c) + | PControl i :: c => nil + end. + +Fixpoint extract_ctl (c: code) := + match c with + | nil => None + | PBasic i :: c => extract_ctl c + | PControl i :: nil => Some i + | PControl i :: _ => None (* if the first found control instruction isn't the last *) + end. + +(** * Utility for Asmblockgen *) + +Program Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + right. discriminate. + constructor. +Qed. + +(** This definition is not used anymore *) +(* Program Definition bblock_basic_ctl (c: list basic) (i: option control) := + match i with + | Some i => {| header:=nil; body:=c; exit:=Some i |} + | None => + match c with + | _::_ => {| header:=nil; body:=c; exit:=None |} + | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} + end + end. +Next Obligation. + bblock_auto_correct. +Qed. Next Obligation. + bblock_auto_correct. +Qed. *) + + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain + the convention that integer registers are mapped to values of + type [Tint] or [Tlong] (in 64 bit mode), + and float registers to values of type [Tsingle] or [Tfloat]. *) + +Definition regset := Pregmap.t val. + +Definition genv := Genv.t fundef unit. + +Notation "a # b" := (a b) (at level 1, only parsing) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + +(** Undefining some registers *) + +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <- Vundef) + end. + + +(** Assigning a register pair *) +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + +(* TODO: Is it still useful ?? *) + + +(** Assigning multiple registers *) + +(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := + match rl, vl with + | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) + | _, _ => rs + end. + *) +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + Local Open Scope asm. Section RELSEM. @@ -42,13 +847,394 @@ Section RELSEM. Variable ge: genv. +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [Next rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Stuck] if the processor is stuck. *) + +Inductive outcome: Type := + | Next (rs:regset) (m:mem) + | Stuck. +(* Arguments outcome: clear implicits. *) + + + +(** ** Arithmetic Expressions (including comparisons) *) + +Inductive signedness: Type := Signed | Unsigned. + +Inductive intsize: Type := Int | Long. + +Definition itest_for_cmp (c: comparison) (s: signedness) := + match c, s with + | Cne, Signed => ITne + | Ceq, Signed => ITeq + | Clt, Signed => ITlt + | Cge, Signed => ITge + | Cle, Signed => ITle + | Cgt, Signed => ITgt + | Cne, Unsigned => ITneu + | Ceq, Unsigned => ITequ + | Clt, Unsigned => ITltu + | Cge, Unsigned => ITgeu + | Cle, Unsigned => ITleu + | Cgt, Unsigned => ITgtu + end. + +Inductive oporder_ftest := + | Normal (ft: ftest) + | Reversed (ft: ftest) +. + +Definition ftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FToeq + | Cne => Normal FTune + | Clt => Normal FTolt + | Cle => Reversed FToge + | Cgt => Reversed FTolt + | Cge => Normal FToge + end. + +Definition notftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FTune + | Cne => Normal FToeq + | Clt => Normal FTuge + | Cle => Reversed FTult + | Cgt => Reversed FTuge + | Cge => Normal FTult + end. + +(* CoMPare Signed Words to Zero *) +Definition btest_for_cmpswz (c: comparison) := + match c with + | Cne => BTwnez + | Ceq => BTweqz + | Clt => BTwltz + | Cge => BTwgez + | Cle => BTwlez + | Cgt => BTwgtz + end. + +(* CoMPare Signed Doubles to Zero *) +Definition btest_for_cmpsdz (c: comparison) := + match c with + | Cne => BTdnez + | Ceq => BTdeqz + | Clt => BTdltz + | Cge => BTdgez + | Cle => BTdlez + | Cgt => BTdgtz + end. + +Definition cmp_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTwltz => (Some Clt, Int) + | BTwgez => (Some Cge, Int) + | BTwlez => (Some Cle, Int) + | BTwgtz => (Some Cgt, Int) + + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | BTdltz => (Some Clt, Long) + | BTdgez => (Some Cge, Long) + | BTdlez => (Some Cle, Long) + | BTdgtz => (Some Cgt, Long) + end. + +Definition cmpu_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | _ => (None, Int) + end. + + +(* a few lemma on comparisons of unsigned (e.g. pointers) *) + +Definition Val_cmpu_bool cmp v1 v2: option bool := + Val.cmpu_bool (fun _ _ => true) cmp v1 v2. + +Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: + (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmpu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). + +Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): + Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) + (Val_cmpu cmp v1 v2). +Proof. + unfold Val.cmpu, Val_cmpu. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob; simpl. + - erewrite Val_cmpu_bool_correct; eauto. + econstructor. + - econstructor. +Qed. + +Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) + := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). + +Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: + (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmplu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). + +Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): + Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) + (Val_cmplu cmp v1 v2). +Proof. + unfold Val.cmplu, Val_cmplu. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob as [b|]; simpl. + - erewrite Val_cmplu_bool_correct; eauto. + simpl. econstructor. + - econstructor. +Qed. + + + +(** Comparing integers *) +Definition compare_int (t: itest) (v1 v2: val): val := + match t with + | ITne => Val.cmp Cne v1 v2 + | ITeq => Val.cmp Ceq v1 v2 + | ITlt => Val.cmp Clt v1 v2 + | ITge => Val.cmp Cge v1 v2 + | ITle => Val.cmp Cle v1 v2 + | ITgt => Val.cmp Cgt v1 v2 + | ITneu => Val_cmpu Cne v1 v2 + | ITequ => Val_cmpu Ceq v1 v2 + | ITltu => Val_cmpu Clt v1 v2 + | 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 := + let res := match t with + | ITne => Val.cmpl Cne v1 v2 + | ITeq => Val.cmpl Ceq v1 v2 + | ITlt => Val.cmpl Clt v1 v2 + | ITge => Val.cmpl Cge v1 v2 + | ITle => Val.cmpl Cle v1 v2 + | ITgt => Val.cmpl Cgt v1 v2 + | ITneu => Some (Val_cmplu Cne v1 v2) + | ITequ => Some (Val_cmplu Ceq v1 v2) + | ITltu => Some (Val_cmplu Clt v1 v2) + | 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 + | None => Vundef + end + . + +Definition compare_single (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpfs Ceq v1 v2 + | FTune => Val.cmpfs Cne v1 v2 + | FTolt => Val.cmpfs Clt v1 v2 + | FTuge => Val.notbool (Val.cmpfs Clt v1 v2) + | FToge => Val.cmpfs Cge v1 v2 + | FTult => Val.notbool (Val.cmpfs Cge v1 v2) + end. + +Definition compare_float (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpf Ceq v1 v2 + | FTune => Val.cmpf Cne v1 v2 + | FTolt => Val.cmpf Clt v1 v2 + | FTuge => Val.notbool (Val.cmpf Clt v1 v2) + | FToge => Val.cmpf Cge v1 v2 + | FTult => Val.notbool (Val.cmpf Cge v1 v2) + end. + +Definition arith_eval_r n := + match n with + | Ploadsymbol s ofs => Genv.symbol_address ge s ofs + end +. + +Definition arith_eval_rr n v := + match n with + | Pmv => v + | Pnegw => Val.neg v + | Pnegl => Val.negl v + | Pcvtl2w => Val.loword v + | Psxwd => Val.longofint v + | Pzxwd => Val.longofintu v + | Pfnegd => Val.negf v + | Pfnegw => Val.negfs v + | Pfabsd => Val.absf v + | Pfabsw => Val.absfs v + | Pfnarrowdw => Val.singleoffloat v + | Pfwidenlwd => Val.floatofsingle v + | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end + | Pfloatuwrnsz => match Val.singleofintu v with Some f => f | _ => Vundef end + | Pfloatudrnsz => match Val.floatoflongu v with Some f => f | _ => Vundef end + | Pfloatdrnsz => match Val.floatoflong v with Some f => f | _ => Vundef end + | Pfloatudrnsz_i32 => match Val.floatofintu v with Some f => f | _ => Vundef end + | Pfloatdrnsz_i32 => match Val.floatofint v with Some f => f | _ => Vundef end + | Pfixedwrzz => match Val.intofsingle v with Some i => i | _ => Vundef end + | Pfixeduwrzz => match Val.intuofsingle v with Some i => i | _ => Vundef end + | Pfixeddrzz => match Val.longoffloat v with Some i => i | _ => Vundef end + | Pfixedudrzz => match Val.longuoffloat v with Some i => i | _ => Vundef end + | Pfixeddrzz_i32 => match Val.intoffloat v with Some i => i | _ => Vundef end + | Pfixedudrzz_i32 => match Val.intuoffloat v with Some i => i | _ => Vundef end + end. + +Definition arith_eval_ri32 n i := + match n with + | Pmake => Vint i + end. + +Definition arith_eval_ri64 n i := + match n with + | Pmakel => Vlong i + end. + +Definition arith_eval_rf32 n i := + match n with + | Pmakefs => Vsingle i + end. + +Definition arith_eval_rf64 n i := + match n with + | Pmakef => Vfloat i + end. + +Definition arith_eval_rrr n v1 v2 := + match n with + | Pcompw c => compare_int c v1 v2 + | Pcompl c => compare_long c v1 v2 + | Pfcompw c => compare_single c v1 v2 + | Pfcompl c => compare_float c v1 v2 + + | Paddw => Val.add v1 v2 + | Psubw => Val.sub v1 v2 + | Pmulw => Val.mul v1 v2 + | Pandw => Val.and v1 v2 + | Pnandw => Val.notint (Val.and v1 v2) + | Porw => Val.or v1 v2 + | Pnorw => Val.notint (Val.or v1 v2) + | Pxorw => Val.xor v1 v2 + | Pnxorw => Val.notint (Val.xor v1 v2) + | Pandnw => Val.and (Val.notint v1) v2 + | Pornw => Val.or (Val.notint v1) v2 + | Psrlw => Val.shru v1 v2 + | Psraw => Val.shr v1 v2 + | Psllw => Val.shl v1 v2 + + | Paddl => Val.addl v1 v2 + | Psubl => Val.subl v1 v2 + | Pandl => Val.andl v1 v2 + | Pnandl => Val.notl (Val.andl v1 v2) + | Porl => Val.orl v1 v2 + | Pnorl => Val.notl (Val.orl v1 v2) + | Pxorl => Val.xorl v1 v2 + | Pnxorl => Val.notl (Val.xorl v1 v2) + | Pandnl => Val.andl (Val.notl v1) v2 + | Pornl => Val.orl (Val.notl v1) v2 + | Pmull => Val.mull v1 v2 + | Pslll => Val.shll v1 v2 + | Psrll => Val.shrlu v1 v2 + | Psral => Val.shrl v1 v2 + + | Pfaddd => Val.addf v1 v2 + | Pfaddw => Val.addfs v1 v2 + | Pfsbfd => Val.subf v1 v2 + | Pfsbfw => Val.subfs v1 v2 + | Pfmuld => Val.mulf v1 v2 + | Pfmulw => Val.mulfs 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) + | Pmuliw => Val.mul v (Vint i) + | Pandiw => Val.and v (Vint i) + | Pnandiw => Val.notint (Val.and v (Vint i)) + | Poriw => Val.or v (Vint i) + | Pnoriw => Val.notint (Val.or v (Vint i)) + | Pxoriw => Val.xor v (Vint i) + | Pnxoriw => Val.notint (Val.xor v (Vint i)) + | Pandniw => Val.and (Val.notint v) (Vint i) + | Porniw => Val.or (Val.notint v) (Vint i) + | Psraiw => Val.shr v (Vint i) + | Psrliw => Val.shru v (Vint i) + | Pslliw => Val.shl v (Vint i) + | Proriw => Val.ror v (Vint i) + | Psllil => Val.shll v (Vint i) + | Psrlil => Val.shrlu v (Vint i) + | Psrail => Val.shrl 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) + | Pmulil => Val.mull v (Vlong i) + | Pandil => Val.andl v (Vlong i) + | Pnandil => Val.notl (Val.andl v (Vlong i)) + | Poril => Val.orl v (Vlong i) + | Pnoril => Val.notl (Val.orl v (Vlong i)) + | Pxoril => Val.xorl v (Vlong 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) + 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) + end. + +Definition arith_eval_arri32 n v1 v2 v3 := + match n with + | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) + end. + +Definition arith_eval_arri64 n v1 v2 v3 := + match n with + | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) + end. + (* TODO: on pourrait mettre ça dans Asmblock pour factoriser le code en définissant exec_arith_instr ai rs := parexec_arith_instr ai rs rs *) Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := match ai with - | PArithR n d => rsw#d <- (arith_eval_r ge n) + | PArithR n d => rsw#d <- (arith_eval_r n) | PArithRR n d s => rsw#d <- (arith_eval_rr n rsr#s) @@ -66,11 +1252,21 @@ Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := | PArithARRI64 n d s i => rsw#d <- (arith_eval_arri64 n rsr#d rsr#s i) end. +Definition eval_offset (ofs: offset) : res ptrofs := + match ofs with + | Ofsimm n => OK n + | Ofslow id delta => + match (Genv.symbol_address ge id delta) with + | Vptr b ofs => OK ofs + | _ => Error (msg "Asmblock.eval_offset") + end + end. + (** * load/store *) (* TODO: factoriser ? *) Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := - match (eval_offset ge ofs) with + match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with | None => Stuck | Some v => Next (rsw#d <- v) mw @@ -85,7 +1281,7 @@ Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) end. Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := - match (eval_offset ge ofs) with + match (eval_offset ofs) with | OK ptr => match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with | None => Stuck | Some m' => Next rsw m' @@ -99,6 +1295,32 @@ Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem | Some m' => Next rsw m' end. +Definition load_chunk n := + match n with + | Plb => Mint8signed + | Plbu => Mint8unsigned + | Plh => Mint16signed + | Plhu => Mint16unsigned + | Plw => Mint32 + | Plw_a => Many32 + | Pld => Mint64 + | Pld_a => Many64 + | Pfls => Mfloat32 + | Pfld => Mfloat64 + end. + +Definition store_chunk n := + match n with + | Psb => Mint8unsigned + | Psh => Mint16unsigned + | Psw => Mint32 + | Psw_a => Many32 + | Psd => Mint64 + | Psd_a => Many64 + | Pfss => Mfloat32 + | Pfsd => Mfloat64 + end. + (* rem: parexec_store = exec_store *) (** * basic instructions *) @@ -166,6 +1388,41 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := Definition par_nextblock size_b (rs: regset) := rs#PC <- (Val.offset_ptr rs#PC size_b). + +(** TODO: redundant w.r.t Machblock *) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + + + +(** Note: copy-paste from Machblock *) +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + + +(** convert a label into a position in the code *) +Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := + match lb with + | nil => None + | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' + end. + (* TODO: factoriser ? *) Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := match label_pos lbl 0 (fn_blocks f) with @@ -300,6 +1557,85 @@ Proof. unfold det_parexec; auto. Qed. + (* FIXME - R16 and R32 are excluded *) +Definition preg_of (r: mreg) : preg := + match r with + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 + | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 + end. + +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use RISC-V registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextblock]) or branching to a label ([goto_label]). *) + +Definition nextblock (b:bblock) (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). + +(** Looking up bblocks in a code sequence by position. *) +Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := + match lb with + | nil => None + | b :: il => + if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) + else if zeq pos 0 then Some b + else find_bblock (pos - (size b)) il + end. + + +Inductive state: Type := + | State: regset -> mem -> state. + + Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f bundle rs m rs' m', @@ -335,6 +1671,25 @@ End RELSEM. (** Execution of whole programs. *) +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <- Vnullptr + # RA <- Vnullptr in + Genv.init_mem p = Some m0 -> + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs PC = Vnullptr -> + rs GPR0 = Vint r -> + final_state (State rs m) r. + Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f7a35443..6e2539e3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,4 +1,4 @@ -open Asmblock +open Asmvliw open Printf open Camlcoq open InstructionScheduler @@ -7,7 +7,7 @@ open TargetPrinter.Target let debug = false (** - * Extracting infos from Asmblock instructions + * Extracting infos from Asmvliw instructions *) type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset @@ -22,7 +22,7 @@ type ab_inst_rec = { is_control : bool; } -(** Asmblock constructor to string functions *) +(** Asmvliw constructor to string functions *) exception OpaqueInstruction diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index e0890a09..599a4024 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -21,7 +21,7 @@ Require Import Axioms. Local Open Scope error_monad_scope. -Definition match_prog (p tp: Asmblock.program) := +Definition match_prog (p tp: Asmvliw.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: @@ -826,7 +826,7 @@ Qed. Theorem transf_program_correct_Asmvliw: forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). Proof. - eapply forward_simulation_step with (match_states:=fun (s1:Asmblock.state) s2 => s1=s2); eauto. + eapply forward_simulation_step with (match_states:=fun (s1:Asmvliw.state) s2 => s1=s2); eauto. - intros; subst; auto. - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. + eapply exec_step_internal; eauto. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ef02c25a..90ef6a4d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -40,7 +40,7 @@ module Target (*: TARGET*) = let print_label oc lbl = label oc (transl_label lbl) - let int_reg_name = let open Asmblock in function + let int_reg_name = let open Asmvliw in function | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" @@ -62,12 +62,12 @@ module Target (*: TARGET*) = let ireg = ireg - let preg oc = let open Asmblock in function + let preg oc = let open Asmvliw in function | IR r -> ireg oc r | RA -> output_string oc "$ra" | _ -> assert false - let preg_annot = let open Asmblock in function + let preg_annot = let open Asmvliw in function | IR r -> int_reg_name r | RA -> "$ra" | _ -> assert false @@ -160,7 +160,7 @@ module Target (*: TARGET*) = *) (* Offset part of a load or store *) - let offset oc = let open Asmblock in function + let offset oc = let open Asmvliw in function | Ofsimm n -> ptrofs oc n | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) @@ -168,7 +168,7 @@ module Target (*: TARGET*) = | AOff ofs -> offset oc ofs | AReg ro -> ireg oc ro - let icond_name = let open Asmblock in function + let icond_name = let open Asmvliw in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" | ITlt -> "lt" @@ -186,7 +186,7 @@ module Target (*: TARGET*) = let icond oc c = fprintf oc "%s" (icond_name c) - let fcond_name = let open Asmblock in function + let fcond_name = let open Asmvliw in function | FTone -> "one" | FTueq -> "ueq" | FToeq -> "oeq" @@ -198,7 +198,7 @@ module Target (*: TARGET*) = let fcond oc c = fprintf oc "%s" (fcond_name c) - let bcond_name = let open Asmblock in function + let bcond_name = let open Asmvliw in function | BTwnez -> "wnez" | BTweqz -> "weqz" | BTwltz -> "wltz" @@ -279,7 +279,7 @@ module Target (*: TARGET*) = | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in (* jumptables := (lbl, tbl) :: !jumptables; *) - let base_reg = if idx_reg=Asmblock.GPR63 then Asmblock.GPR62 else Asmblock.GPR63 in + let base_reg = if idx_reg=Asmvliw.GPR63 then Asmvliw.GPR62 else Asmvliw.GPR63 in fprintf oc "%s jumptable [ " comment; List.iter (fun l -> fprintf oc "%a " print_label l) tbl; fprintf oc "]\n"; diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index d0e05389..8a83521c 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -16,7 +16,7 @@ Require Import Asmblockgen. Require Import Conventions1. Module MB:=Machblock. -Module AB:=Asmblock. +Module AB:=Asmvliw. Hint Extern 2 (_ <> _) => congruence: asmgen. @@ -311,9 +311,9 @@ Qed. Lemma agree_undef_caller_save_regs: forall ms sp rs, agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (Asmblock.undef_caller_save_regs rs). + agree (Mach.undef_caller_save_regs ms) sp (Asmvliw.undef_caller_save_regs rs). Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmblock.undef_caller_save_regs; split. + intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.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). -- cgit From 76af54d8ae77f843b7f6f15f9a0fc6124df47ebb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 5 Apr 2019 17:25:36 +0200 Subject: #91 Removed completely the duplicated semantics in Asmblock --- mppa_k1c/Asmblock.v | 189 ++----------------------------------- mppa_k1c/Asmblockdeps.v | 68 ++++++------- mppa_k1c/Asmblockgenproof.v | 4 +- mppa_k1c/Asmblockgenproof1.v | 29 +++--- mppa_k1c/PostpassSchedulingproof.v | 36 ++++--- mppa_k1c/lib/Asmblockgenproof0.v | 20 +++- 6 files changed, 89 insertions(+), 257 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3bcb321d..c7528272 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -39,113 +39,21 @@ Section RELSEM. Variable ge: genv. - -Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := - match ai with - | PArithR n d => rs#d <- (arith_eval_r ge n) - - | PArithRR n d s => rs#d <- (arith_eval_rr n rs#s) - - | PArithRI32 n d i => rs#d <- (arith_eval_ri32 n i) - | PArithRI64 n d i => rs#d <- (arith_eval_ri64 n i) - | PArithRF32 n d i => rs#d <- (arith_eval_rf32 n i) - | PArithRF64 n d i => rs#d <- (arith_eval_rf64 n i) - - | PArithRRR n d s1 s2 => rs#d <- (arith_eval_rrr n rs#s1 rs#s2) - - | PArithRRI32 n d s i => rs#d <- (arith_eval_rri32 n rs#s i) - - | PArithRRI64 n d s i => rs#d <- (arith_eval_rri64 n rs#s i) - - | PArithARRR n d s1 s2 => rs#d <- (arith_eval_arrr n rs#d rs#s1 rs#s2) - - | PArithARRI32 n d s i => rs#d <- (arith_eval_arri32 n rs#d rs#s i) - - | PArithARRI64 n d s i => rs#d <- (arith_eval_arri64 n rs#d rs#s i) - end. - -(** * load/store *) +Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec_arith_instr ge ai rs rs. (** Auxiliaries for memory accesses *) +Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset ge chunk rs rs m m d a ofs. -Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := - match (eval_offset ge ofs) with - | OK ptr => match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with - | None => Stuck - | Some v => Next (rs#d <- v) m - end - | _ => Stuck - end. - -Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := - match Mem.loadv chunk m (Val.addl (rs a) (rs ro)) with - | None => Stuck - | Some v => Next (rs#d <- v) m - end. - -Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := - match (eval_offset ge ofs) with - | OK ptr => match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with - | None => Stuck - | Some m' => Next rs m' - end - | _ => Stuck - end. - -Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := - match Mem.storev chunk m (Val.addl (rs a) (rs ro)) (rs s) with - | None => Stuck - | Some m' => Next rs m' - end. +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_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset ge chunk rs rs m m s a ofs. +Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. (** * basic instructions *) -Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := - match bi with - | PArith ai => Next (exec_arith_instr ai rs) m - - | PLoadRRO n d a ofs => exec_load_offset (load_chunk n) rs m d a ofs - | PLoadRRR n d a ro => exec_load_reg (load_chunk n) rs m d a ro - - | PStoreRRO n s a ofs => exec_store_offset (store_chunk n) rs m s a ofs - | PStoreRRR n s a ro => exec_store_reg (store_chunk n) rs m s a ro - - | Pallocframe sz pos => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with - | None => Stuck - | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #RTMP <- Vundef) m2 - end - - | Pfreeframe sz pos => - match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with - | None => Stuck - | Some v => - match rs SP with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => Stuck - | Some m' => Next (rs#SP <- v #RTMP <- Vundef) m' - end - | _ => Stuck - end - end - | Pget rd ra => - match ra with - | RA => Next (rs#rd <- (rs#ra)) m - | _ => Stuck - end - | Pset ra rd => - match ra with - | RA => Next (rs#ra <- (rs#rd)) m - | _ => Stuck - end - | Pnop => Next rs m -end. +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := parexec_basic_instr ge bi rs rs m m. Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := match body with @@ -157,34 +65,16 @@ 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 := - match label_pos lbl 0 (fn_blocks f) with - | None => Stuck - | Some pos => - match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m - | _ => Stuck - end - end. +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 := - match res with - | Some true => goto_label f l rs m - | Some false => Next rs m - | None => Stuck - end. - +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. (** Execution of a single control-flow instruction [i] in initial state [rs] and [m]. Return updated state. @@ -202,55 +92,7 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti we generate cannot use those registers to hold values that must survive the execution of the pseudo-instruction. *) -Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := - match oc with - | Some ic => -(** Get/Set system registers *) - match ic with - - -(** Branch Control Unit instructions *) - | Pret => - Next (rs#PC <- (rs#RA)) m - | Pcall s => - Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Picall r => - Next (rs#RA <- (rs#PC) #PC <- (rs#r)) m - | Pgoto s => - Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m - | Pigoto r => - Next (rs#PC <- (rs#r)) m - | Pj_l l => - goto_label f l rs m - | Pjumptable r tbl => - match rs#r with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => Stuck - | Some lbl => goto_label f lbl (rs #GPR62 <- Vundef #GPR63 <- Vundef) m - end - | _ => Stuck - end - - | Pcb bt r l => - match cmp_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs#r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs#r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - | Pcbu bt r l => - match cmpu_for_btest bt with - | (Some c, Int) => eval_branch f l rs m (Val_cmpu_bool c rs#r (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch f l rs m (Val_cmplu_bool c rs#r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - -(** Pseudo-instructions *) - | Pbuiltin ef args res => - Stuck (**r treated specially below *) - end - | None => Next rs m -end. +Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := match exec_body (body b) rs0 m with @@ -259,19 +101,6 @@ Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcom | Stuck => Stuck end. -(** Translation of the LTL/Linear/Mach view of machine registers to - the RISC-V view. Note that no LTL register maps to [X31]. This - register is reserved as temporary, to be used by the generated RV32G - code. *) - - - - - - - -(** Execution of the instruction at [rs PC]. *) - (** TODO * For now, we consider a builtin is alone in a basic block. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 32e5e5bb..a88a2dff 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -729,7 +729,7 @@ Lemma trans_arith_correct: inst_run (Genv ge fn) (trans_arith i) s s = Some s' /\ match_states (State rs' m) s'. Proof. - intros. unfold exec_arith_instr in H. destruct i. + intros. unfold exec_arith_instr in H. unfold parexec_arith_instr in H. destruct i. (* Ploadsymbol *) - inv H; inv H0. eexists; split; try split. * Simpl. @@ -816,16 +816,16 @@ Theorem forward_simu_basic_gen ge fn b rs m s: Proof. intros. destruct b; inversion H; simpl. (* Arith *) - - eapply trans_arith_correct; eauto. + - eapply trans_arith_correct; eauto. destruct i; simpl; reflexivity. (* Load *) - destruct i. (* Load Offset *) + destruct i; simpl; - unfold exec_load_offset; rewrite (H1 ra); rewrite H0; + unfold parexec_load_offset; rewrite (H1 ra); rewrite H0; destruct (eval_offset _ _); simpl; auto; destruct (Mem.loadv _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + destruct i; simpl; - unfold exec_load_reg; rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_load_deps_reg; + unfold parexec_load_reg; rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_load_deps_reg; destruct (Mem.loadv _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. @@ -833,12 +833,12 @@ Proof. - destruct i. (* Store Offset *) + destruct i; simpl; - rewrite (H1 rs0); rewrite (H1 ra); rewrite H0; unfold exec_store_offset; destruct (eval_offset _ _); simpl; auto; + rewrite (H1 rs0); rewrite (H1 ra); rewrite H0; unfold parexec_store_offset; destruct (eval_offset _ _); simpl; auto; destruct (Mem.storev _ _ _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + destruct i; simpl; - rewrite (H1 rs0); rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_store_reg; unfold exec_store_deps_reg; + rewrite (H1 rs0); rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold parexec_store_reg; unfold exec_store_deps_reg; destruct (Mem.storev _ _ _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. (* Allocframe *) @@ -914,39 +914,39 @@ Proof. (* Pjumptable *) + Simpl. rewrite (H2 r). destruct (rs r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. - unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. destruct (preg_eq GPR62 g). rewrite e. Simpl. destruct (preg_eq GPR63 g). rewrite e. Simpl. Simpl. (* Pj_l *) - + Simpl. unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. + + Simpl. unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. (* Pcb *) - + Simpl. destruct (cmp_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. + + Simpl. destruct (cmp_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold par_eval_branch; unfold eval_branch_deps. ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. (* Pcbu *) - + Simpl. destruct (cmpu_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. + + Simpl. destruct (cmpu_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold par_eval_branch; unfold eval_branch_deps. ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. @@ -1090,41 +1090,41 @@ Proof. (* Pjumptable *) - simpl in *. repeat (rewrite H3 in H1). destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. - unfold goto_label_deps in H1. unfold goto_label. Simpl. + unfold goto_label_deps in H1. unfold par_goto_label. Simpl. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. (* Pj_l *) - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. - unfold goto_label_deps in H1. unfold goto_label. + unfold goto_label_deps in H1. unfold par_goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. (* Pcb *) - simpl in *. destruct (cmp_for_btest bt). destruct i. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold eval_branch. + unfold eval_branch_deps in H1; unfold par_eval_branch. destruct (Val.cmp_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold eval_branch. + unfold eval_branch_deps in H1; unfold par_eval_branch. destruct (Val.cmpl_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. (* Pcbu *) - simpl in *. destruct (cmpu_for_btest bt). destruct i. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold eval_branch. + unfold eval_branch_deps in H1; unfold par_eval_branch. destruct (Val_cmpu_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 PC); simpl in e; rewrite e in H1; clear e. destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold eval_branch. + unfold eval_branch_deps in H1; unfold par_eval_branch. destruct (Val_cmplu_bool _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold goto_label. destruct (label_pos _ _ _); auto. + unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. Qed. @@ -1173,37 +1173,37 @@ Proof. destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). (* Pjumptable *) - simpl in *. repeat (rewrite H3). destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. - unfold goto_label_deps. unfold goto_label in H0. + unfold goto_label_deps. unfold par_goto_label in H0. destruct (label_pos _ _ _); auto. repeat (rewrite Pregmap.gso in H0; try discriminate). destruct (rs PC); auto. discriminate. (* Pj_l *) - - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold goto_label in H0. + - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold par_goto_label in H0. destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. (* Pcb *) - simpl in *. destruct (cmp_for_btest bt). destruct i. -- destruct o. - + unfold eval_branch in H0; unfold eval_branch_deps. + + unfold par_eval_branch in H0; unfold eval_branch_deps. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmp_bool _ _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. -- destruct o. - + unfold eval_branch in H0; unfold eval_branch_deps. + + unfold par_eval_branch in H0; unfold eval_branch_deps. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmpl_bool _ _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. (* Pcbu *) - simpl in *. destruct (cmpu_for_btest bt). destruct i. -- destruct o. - + unfold eval_branch in H0; unfold eval_branch_deps. + + unfold par_eval_branch in H0; unfold eval_branch_deps. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmpu_bool _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. -- destruct o. - + unfold eval_branch in H0; unfold eval_branch_deps. + + unfold par_eval_branch in H0; unfold eval_branch_deps. pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmplu_bool _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold goto_label in H0. clear e0. + destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. Qed. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index a071a9f8..1fbe7832 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -259,7 +259,7 @@ Proof. exploit label_pos_code_tail; eauto. instantiate (1 := 0). intros [pos' [P [Q R]]]. exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. rewrite P. rewrite H1. auto. + split. 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. @@ -1680,7 +1680,7 @@ Proof. { change (fn_blocks tf) with tfbody; unfold tfbody. apply exec_straight_blocks_step with rs2 m2'. unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity. + rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. rewrite regset_same_assign. reflexivity. reflexivity. eapply exec_straight_blocks_trans. - eexact W'. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5ccea246..d44b033c 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1060,13 +1060,10 @@ Lemma transl_cbranch_correct_false: /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. - intros. exploit transl_cbranch_correct_1; eauto. + intros. exploit transl_cbranch_correct_1. all: eauto. simpl eval_branch. instantiate (1 := tbb). + intros (rs' & insn & A & B & C). rewrite regset_same_assign in B. + eexists; eexists. split; try split. all: eassumption. Qed. -(* intros (rs' & insn & A & B & C). - exists rs'. - split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. - intros; Simpl. - *) (** Translation of condition operators *) @@ -1749,7 +1746,7 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load_offset. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. + unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. split; intros; Simpl. auto. Qed. @@ -1769,7 +1766,7 @@ Proof. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store_offset. rewrite PtrEq. rewrite B, C, STORE. + unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq. rewrite B, C, STORE. eauto. discriminate. { intro. inv H. contradiction. } @@ -1948,7 +1945,7 @@ Proof. 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. rewrite B, LOAD. reflexivity. Simpl. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. split; intros; Simpl. auto. Qed. @@ -1969,7 +1966,7 @@ Proof. 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. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. split; intros; Simpl. auto. Qed. @@ -2055,7 +2052,7 @@ Proof. intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. 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_store_reg. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + rewrite INSTR. unfold exec_store_reg. unfold parexec_store_reg. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. intro. inv H. contradiction. auto. Qed. @@ -2077,7 +2074,7 @@ Proof. 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_store_offset. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. + rewrite INSTR. unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. intro. inv H. contradiction. auto. Qed. @@ -2086,14 +2083,14 @@ Qed. Remark exec_store_offset_8_sign rs m x base ofs: exec_store_offset ge Mint8unsigned rs m x base ofs = exec_store_offset ge Mint8signed rs m x base ofs. Proof. - unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. + unfold exec_store_offset. unfold parexec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. Qed. Remark exec_store_offset_16_sign rs m x base ofs: exec_store_offset ge Mint16unsigned rs m x base ofs = exec_store_offset ge Mint16signed rs m x base ofs. Proof. - unfold exec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. + unfold exec_store_offset. unfold parexec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. Qed. @@ -2135,14 +2132,14 @@ Qed. Remark exec_store_reg_8_sign rs m x base ofs: exec_store_reg Mint8unsigned rs m x base ofs = exec_store_reg Mint8signed rs m x base ofs. Proof. - unfold exec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. Qed. Remark exec_store_reg_16_sign rs m x base ofs: exec_store_reg Mint16unsigned rs m x base ofs = exec_store_reg Mint16signed rs m x base ofs. Proof. - unfold exec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. Qed. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 599a4024..a2dd2ec2 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -100,7 +100,7 @@ Lemma exec_load_offset_pc_var: exec_load_offset ge t rs m rd ra ofs = Next rs' m' -> exec_load_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. + intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - discriminate. @@ -111,7 +111,7 @@ Lemma exec_load_reg_pc_var: 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 *. rewrite Pregmap.gso; try discriminate. + 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. @@ -122,7 +122,7 @@ Lemma exec_store_offset_pc_var: exec_store_offset ge t rs m rd ra ofs = Next rs' m' -> exec_store_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. - intros. unfold exec_store_offset in *. rewrite Pregmap.gso; try discriminate. + intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ge ofs); try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. @@ -134,7 +134,7 @@ Lemma exec_store_reg_pc_var: 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 *. rewrite Pregmap.gso; try discriminate. + 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. @@ -145,13 +145,13 @@ Lemma exec_basic_instr_pc_var: 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 *. destruct i. + 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). + 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. @@ -223,10 +223,11 @@ Proof. exploit concat2_decomp; eauto. intros. inv H. unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. + eexists; eexists. split. unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. + split. exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. - unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. + unfold exec_bblock. unfold nextblock. rewrite regset_same_assign. erewrite exec_body_pc_var; eauto. rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. assert (size bb = size a + size b). { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. @@ -571,13 +572,8 @@ Proof. assert (ge = Genv.globalenv prog). auto. assert (tge = Genv.globalenv tprog). auto. pose symbol_address_preserved. - exploreInst; simpl; auto; try congruence. - - unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. - - unfold eval_branch. unfold goto_label. erewrite label_pos_preserved_blocks; eauto. + exploreInst; simpl; auto; try congruence; + unfold par_goto_label; unfold par_eval_branch; unfold par_goto_label; erewrite label_pos_preserved_blocks; eauto. Qed. Lemma eval_offset_preserved: @@ -589,21 +585,21 @@ Qed. Lemma transf_exec_load_offset: forall t rs m rd ra ofs, exec_load_offset ge t rs m rd ra ofs = exec_load_offset tge t rs m rd ra ofs. Proof. - intros. unfold exec_load_offset. rewrite eval_offset_preserved. reflexivity. + intros. unfold exec_load_offset. unfold parexec_load_offset. rewrite eval_offset_preserved. reflexivity. Qed. Lemma transf_exec_store_offset: forall t rs m rs0 ra ofs, exec_store_offset ge t rs m rs0 ra ofs = exec_store_offset tge t rs m rs0 ra ofs. Proof. - intros. unfold exec_store_offset. rewrite eval_offset_preserved. reflexivity. + intros. unfold exec_store_offset. unfold parexec_store_offset. rewrite eval_offset_preserved. reflexivity. Qed. 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. exploreInst; simpl; auto; try congruence. - - unfold exec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. + unfold exec_basic_instr. unfold parexec_basic_instr. exploreInst; simpl; auto; try congruence. + - unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. - apply transf_exec_load_offset. - apply transf_exec_store_offset. Qed. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 8a83521c..a44c40d8 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -14,6 +14,7 @@ Require Import Machblock. Require Import Asmblock. Require Import Asmblockgen. Require Import Conventions1. +Require Import Axioms. Module MB:=Machblock. Module AB:=Asmvliw. @@ -943,10 +944,10 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - 1-10: try (unfold exec_load_offset in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold exec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold exec_store_offset in H1; destruct (eval_offset ge ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 1-10: try (unfold exec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. + 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ge 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_store_offset in H1; destruct (eval_offset ge 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. - 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. @@ -997,6 +998,13 @@ Proof. + 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. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + Lemma exec_straight_through_singleinst: forall a b rs1 m1 rs2 m2 rs2' m2' lb, bblock_single_inst (PBasic a) = b -> @@ -1005,10 +1013,12 @@ Lemma exec_straight_through_singleinst: exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. Proof. intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. auto. + simpl. rewrite regset_same_assign. auto. simpl; auto. unfold nextblock; 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. *) -- cgit From fb8c244726595b0e7a4db8c0f8e6aa3f3549cc14 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 5 Apr 2019 18:14:07 +0200 Subject: relecture sylvain avec TODOs pour refactoring #90 --- mppa_k1c/Asmblock.v | 412 +++++++++++++++++++++-------------- mppa_k1c/Asmblockdeps.v | 34 +-- mppa_k1c/Asmblockgenproof.v | 20 +- mppa_k1c/Asmblockgenproof1.v | 12 +- mppa_k1c/Asmvliw.v | 367 ++++++------------------------- mppa_k1c/PostpassSchedulingOracle.ml | 1 + mppa_k1c/PostpassSchedulingproof.v | 10 +- mppa_k1c/lib/Asmblockgenproof0.v | 2 +- 8 files changed, 353 insertions(+), 505 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3bcb321d..0f65b1d0 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -33,13 +33,234 @@ Require Import Conventions. Require Import Errors. Require Export Asmvliw. + +(** * Auxiliary utilies on basic blocks *) + +(** ** A unified view of Kalray instructions *) + +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control) +. + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. + +Definition code := list instruction. +Definition bcode := list basic. + +Fixpoint basics_to_code (l: list basic) := + match l with + | nil => nil + | bi::l => (PBasic bi)::(basics_to_code l) + end. + +Fixpoint code_to_basics (c: code) := + match c with + | (PBasic i)::c => + match code_to_basics c with + | None => None + | Some l => Some (i::l) + end + | _::c => None + | nil => Some nil + end. + +Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. +Proof. + intros. induction c as [|i c]; simpl; auto. + rewrite IHc. auto. +Qed. + +Lemma code_to_basics_dist: + forall c c' l l', + code_to_basics c = Some l -> + code_to_basics c' = Some l' -> + code_to_basics (c ++ c') = Some (l ++ l'). +Proof. + induction c as [|i c]; simpl; auto. + - intros. inv H. simpl. auto. + - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. + inv H. erewrite IHc; eauto. auto. +Qed. + +(** + Asmblockgen will have to translate a Mach control into a list of instructions of the form + i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction + These functions provide way to extract the basic / control instructions +*) + +Fixpoint extract_basic (c: code) := + match c with + | nil => nil + | PBasic i :: c => i :: (extract_basic c) + | PControl i :: c => nil + end. + +Fixpoint extract_ctl (c: code) := + match c with + | nil => None + | PBasic i :: c => extract_ctl c + | PControl i :: nil => Some i + | PControl i :: _ => None (* if the first found control instruction isn't the last *) + end. + +(** ** Wellformness of basic blocks *) + +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. + +Definition non_empty_bblock (body: list basic) (exit: option control): Prop + := body <> nil \/ exit <> None. + +Lemma non_empty_bblock_refl: + forall body exit, + non_empty_bblock body exit <-> + Is_true (non_empty_bblockb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. intros. inversion H; contradiction. + - destruct body; destruct exit. + all: simpl; auto. + all: intros; try (right; discriminate); try (left; discriminate). + contradiction. +Qed. + +Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, + exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. + + +Lemma builtin_alone_refl: + forall body exit, + builtin_alone body exit <-> Is_true (builtin_aloneb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. + all: exploreInst; simpl; auto. + unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. + assert (b :: body = nil). eapply H; eauto. discriminate. + - destruct body; destruct exit. + all: simpl; auto; try constructor. + + exploreInst; try discriminate. + simpl. contradiction. + + intros. discriminate. +Qed. + +Definition wf_bblock (body: list basic) (exit: option control) := + non_empty_bblock body exit /\ builtin_alone body exit. + +Lemma wf_bblock_refl: + forall body exit, + wf_bblock body exit <-> Is_true (wf_bblockb body exit). +Proof. + intros. split. + - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + apply andb_prop_intro. auto. + - intros. apply andb_prop_elim in H. inv H. + apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + unfold wf_bblock. split; auto. +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. + destruct b; simpl; auto. + - destruct p1, p2; auto. + - destruct p1. +Qed. + +Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +Proof. + destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. + intros; subst. + rewrite (Istrue_proof_irrelevant _ c1 c2). + auto. +Qed. + +Program Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + right. discriminate. + constructor. +Qed. + +Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. +Proof. + intros. destruct l; try (contradict H; auto; fail). + simpl. omega. +Qed. + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. simpl. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. simpl. apply gt_irrefl. +Qed. + +Lemma size_positive (b:bblock): size b > 0. +Proof. + unfold size. destruct b as [hd bdy ex cor]. simpl. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). + inversion cor; contradict H; simpl; auto. +Qed. + + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. +Qed. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +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. (** Execution of arith instructions *) Variable ge: genv. - +(* TODO: delete this or define it as [parexec_arith_instr ge ai rs rs] *) Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := match ai with | PArithR n d => rs#d <- (arith_eval_r ge n) @@ -68,7 +289,7 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := (** Auxiliaries for memory accesses *) - +(* TODO: delete this or define it as [parexec_load_offset ge chunk rs rs m m d a ofs] *) Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := match (eval_offset ge ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr (rs a) ptr) with @@ -78,12 +299,14 @@ Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ir | _ => Stuck end. +(* TODO: delete this or define it as [parexec_load_reg ge chunk rs rs m m d a ro] *) Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := match Mem.loadv chunk m (Val.addl (rs a) (rs ro)) with | None => Stuck | Some v => Next (rs#d <- v) m end. +(* TODO: delete this as define it as ... *) Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := match (eval_offset ge ofs) with | OK ptr => match Mem.storev chunk m (Val.offset_ptr (rs a) ptr) (rs s) with @@ -93,6 +316,7 @@ Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: i | _ => Stuck end. +(* TODO: delete this as define it as ... *) Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := match Mem.storev chunk m (Val.addl (rs a) (rs ro)) (rs s) with | None => Stuck @@ -103,6 +327,7 @@ Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: i (** * basic instructions *) +(* TODO: define this [parexec_basic_instr ge bi rs rs m m] *) Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := match bi with | PArith ai => Next (exec_arith_instr ai rs) m @@ -157,12 +382,9 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. +(** * control-flow instructions *) - -(** Position corresponding to a label *) - - - +(* TODO: delete this or define it as [par_goto_label ge f lbl rs rs m] *) Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := match label_pos lbl 0 (fn_blocks f) with | None => Stuck @@ -173,11 +395,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome end end. -(** Evaluating a branch - -Warning: in m PC is assumed to be already pointing on the next instruction ! - -*) +(* TODO: delete this or define it as [par_eval_branch ge f l rs rs m res] *) Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := match res with | Some true => goto_label f l rs m @@ -185,23 +403,7 @@ Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: opti | None => Stuck end. - -(** Execution of a single control-flow instruction [i] in initial state [rs] and - [m]. Return updated state. - - As above: PC is assumed to be incremented on the next block before the control-flow instruction - - 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. - - 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. *) - +(* TODO: delete this or define it as [parexec_control ge f oc rs rs m] *) Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := match oc with | Some ic => @@ -252,32 +454,30 @@ Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) | None => Next rs m end. +(* TODO: change [exec_bblock] for a definition like this one: + +Definition exec_exit (f: function) ext size_b (rs: regset) (m: mem) + := parexec_exit ge f ext size_b rs rs m. + Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := match exec_body (body b) rs0 m with - | Next rs' m' => - let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' + | Next rs' m' => exec_exit f (exit b) (Ptrofs.repr (size b)) rs' m' | Stuck => Stuck end. -(** Translation of the LTL/Linear/Mach view of machine registers to - the RISC-V view. Note that no LTL register maps to [X31]. This - register is reserved as temporary, to be used by the generated RV32G - code. *) - - - - +*) +Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := + match exec_body (body b) rs0 m with + | Next rs' m' => + let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' + | Stuck => Stuck + end. (** Execution of the instruction at [rs PC]. *) -(** TODO - * For now, we consider a builtin is alone in a basic block. - * Perhaps there is a way to avoid that ? - *) - Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f bi rs m rs' m', @@ -318,68 +518,6 @@ End RELSEM. Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). -(* Useless - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. - + split. constructor. auto. - + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate. - rewrite H9 in H4. discriminate. - + unfold exec_bblock in H13. destruct (exec_body _ _ _ _); try discriminate. - rewrite H4 in H13. discriminate. - + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H6. eexact H13. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. -*) Definition data_preg (r: preg) : bool := match r with @@ -390,65 +528,3 @@ Definition data_preg (r: preg) : bool := | PC => false end. -(** Determinacy of the [Asm] semantics. *) - -(* Useless. - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. - split. constructor. auto. - discriminate. - discriminate. - assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H11. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. unfold Vzero in H0. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. -*) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 32e5e5bb..01f5ca20 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -910,7 +910,7 @@ Theorem forward_simu_control_gen ge fn ex b rs m s: Proof. intros. destruct ex; simpl; inv H0. - destruct c; destruct i; simpl; rewrite (H2 PC); auto. - all: try (eexists; split; try split; Simpl; intros rr; destruct rr; unfold nextblock; Simpl). + all: try (eexists; split; try split; Simpl; intros rr; destruct rr; unfold nextblock, incrPC; Simpl). (* Pjumptable *) + Simpl. rewrite (H2 r). destruct (rs r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. @@ -922,18 +922,18 @@ Proof. (* Pj_l *) + Simpl. unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. - unfold nextblock. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + unfold nextblock, incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. (* Pcb *) + Simpl. destruct (cmp_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. @@ -941,12 +941,12 @@ Proof. (* Pcbu *) + Simpl. destruct (cmpu_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold eval_branch; unfold eval_branch_deps. ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock; Simpl. + +++ unfold goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. @@ -1813,31 +1813,31 @@ Theorem forward_simu_par_control_gen ge fn rsr rsw mr mw sr sw sz ex: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - match_outcome (parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). + match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. intros GENV MSR MSW. simpl in *. inv MSR. inv MSW. destruct ex. - destruct c; destruct i; try discriminate; simpl. - all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold par_nextblock; Simpl). + all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold incrPC; Simpl). (* Pjumptable *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold par_nextblock. Simpl. + + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold incrPC. Simpl. destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold par_nextblock; Simpl. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. destruct (preg_eq g GPR62). rewrite e. Simpl. destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. (* Pj_l *) + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. - unfold par_nextblock. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold par_nextblock; Simpl. + unfold incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. (* Pcb *) + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold par_nextblock. Simpl. destruct i. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. @@ -1851,7 +1851,7 @@ Proof. (* Pcbu *) + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold par_nextblock. Simpl. destruct i. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. @@ -1864,14 +1864,14 @@ Proof. +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. - intros rr; destruct rr; unfold par_nextblock; Simpl. + intros rr; destruct rr; unfold incrPC; Simpl. Qed. Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> + parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> exists s', inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' /\ match_states (State rs' m') s'. @@ -1885,7 +1885,7 @@ Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_control ge fn ex (par_nextblock (Ptrofs.repr sz) rsr) rsw mw = Stuck -> + parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw = Stuck -> inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. Proof. intros. exploit forward_simu_par_control_gen. 3: eapply H1. 2: eapply H0. all: eauto. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index a071a9f8..d93afba5 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -839,7 +839,7 @@ Proof. exploit find_label_goto_label. eauto. eauto. instantiate (2 := rs2'). - { subst. unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } eauto. intros (tc' & rs' & GOTO & AT2 & INV). @@ -847,7 +847,7 @@ Proof. rewrite H6. simpl extract_basic. simpl. eauto. rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock in INV. + 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. @@ -886,7 +886,7 @@ Proof. 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; Simpl. } + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } intros. discriminate. * (* MBcond false *) @@ -912,10 +912,10 @@ Proof. rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. econstructor; eauto. - unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. 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; Simpl. } + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } intros. discriminate. + (* MBjumptable *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. @@ -926,7 +926,7 @@ Proof. 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. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + 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]]]]. @@ -959,7 +959,7 @@ Proof. rewrite H6. simpl extract_basic. eauto. rewrite H7. simpl extract_ctl. simpl. reflexivity. econstructor; eauto. - unfold nextblock. repeat apply agree_set_other; auto with asmgen. + 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. *) @@ -969,7 +969,7 @@ Proof. monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. simpl. repeat eexists. econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. + 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. @@ -1398,7 +1398,7 @@ Proof. eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. unfold exec_bblock. simpl. eauto. econstructor. eauto. eauto. eauto. - unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite <- H. + 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. @@ -1581,7 +1581,7 @@ Proof. eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock. rewrite Pregmap.gss. + 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. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5ccea246..a43b228e 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -745,7 +745,7 @@ Proof. * constructor. * split; auto. simpl. intros. assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock. Simpl. rewrite H1 in H0. + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) auto; @@ -772,7 +772,7 @@ Proof. * constructor. * split; auto. simpl. intros. assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock. Simpl. rewrite H1 in H0. + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0. auto. - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); @@ -821,7 +821,7 @@ Proof. * constructor. * split; auto. simpl. intros. assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock. Simpl. rewrite H1 in H0. + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0; auto. - (* c = Cne *) @@ -846,7 +846,7 @@ Proof. * constructor. * split; auto. simpl. intros. assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock. Simpl. rewrite H1 in H0. + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. auto; unfold eval_branch. rewrite H0; auto. - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); @@ -903,7 +903,7 @@ Proof. * constructor. * split; auto. assert (rs x = (nextblock tbb rs) x). - unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. + unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm32_correct RTMP n); eauto. intros (rs' & A & B & C). @@ -966,7 +966,7 @@ Proof. * constructor. * split; auto. assert (rs x = (nextblock tbb rs) x). - unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. + unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + exploit (loadimm64_correct RTMP n); eauto. intros (rs' & A & B & C). diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index d56a7a84..6c18ac32 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -15,7 +15,9 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for K1c assembly language. *) +(** 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. @@ -35,6 +37,12 @@ Require Import Sorting.Permutation. (** * Abstract syntax *) +(** A K1c program is syntactically given as a list of functions. + Each function is associated to a list of bundles of type [bblock] below. + Hence, syntactically, we view each bundle as a basic block: + this view induces our sequential semantics of bundles defined in [Asmblock]. +*) + (** General Purpose registers. *) @@ -481,21 +489,7 @@ Coercion PExpand: ex_instruction >-> control. Coercion PCtlFlow: cf_instruction >-> control. -(** * Definition of a bblock *) - -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. - -Definition non_empty_bblock (body: list basic) (exit: option control): Prop - := body <> nil \/ exit <> None. +(** * Definition of a bblock (ie a bundle) *) Definition non_empty_body (body: list basic): bool := match body with @@ -511,23 +505,11 @@ Definition non_empty_exit (exit: option control): bool := Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. -Lemma non_empty_bblock_refl: - forall body exit, - non_empty_bblock body exit <-> - Is_true (non_empty_bblockb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. intros. inversion H; contradiction. - - destruct body; destruct exit. - all: simpl; auto. - all: intros; try (right; discriminate); try (left; discriminate). - contradiction. -Qed. - -Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, - exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. +(** TODO + * For now, we consider a builtin is alone in a bundle (and a basic block). + * Is there a way to avoid that ? + *) Definition builtin_aloneb (body: list basic) (exit: option control) := match exit with | Some (PExpand (Pbuiltin _ _ _)) => @@ -538,41 +520,9 @@ Definition builtin_aloneb (body: list basic) (exit: option control) := | _ => true end. -Lemma builtin_alone_refl: - forall body exit, - builtin_alone body exit <-> Is_true (builtin_aloneb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. - all: exploreInst; simpl; auto. - unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. - assert (b :: body = nil). eapply H; eauto. discriminate. - - destruct body; destruct exit. - all: simpl; auto; try constructor. - + exploreInst; try discriminate. - simpl. contradiction. - + intros. discriminate. -Qed. - Definition wf_bblockb (body: list basic) (exit: option control) := (non_empty_bblockb body exit) && (builtin_aloneb body exit). -Definition wf_bblock (body: list basic) (exit: option control) := - non_empty_bblock body exit /\ builtin_alone body exit. - -Lemma wf_bblock_refl: - forall body exit, - wf_bblock body exit <-> Is_true (wf_bblockb body exit). -Proof. - intros. split. - - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - apply andb_prop_intro. auto. - - intros. apply andb_prop_elim in H. inv H. - apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - unfold wf_bblock. split; auto. -Qed. - (** A bblock is well-formed if he contains at least one instruction, and if there is a builtin then it must be alone in this bblock. *) @@ -583,26 +533,7 @@ Record bblock := mk_bblock { correct: Is_true (wf_bblockb body exit) }. -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. - destruct b; simpl; auto. - - destruct p1, p2; auto. - - destruct p1. -Qed. - -Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. -Proof. - destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. - intros; subst. - rewrite (Istrue_proof_irrelevant _ c1 c2). - auto. -Qed. - - -(* FIXME: redundant with definition in Machblock *) +(* FIXME? redundant with definition in Machblock *) Definition length_opt {A} (o: option A) : nat := match o with | Some o => 1 @@ -614,66 +545,6 @@ Definition length_opt {A} (o: option A) : nat := The result is in Z to be compatible with operations on PC *) Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). -(* match (body b, exit b) with - | (nil, None) => 1 - | _ => - end. - *) - -Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. -Proof. - intros. destruct l; try (contradict H; auto; fail). - simpl. omega. -Qed. - -Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. -Proof. - intros. destruct z; auto. - - contradict H. simpl. apply gt_irrefl. - - apply Zgt_pos_0. - - contradict H. simpl. apply gt_irrefl. -Qed. - -Lemma size_positive (b:bblock): size b > 0. -Proof. - unfold size. destruct b as [hd bdy ex cor]. simpl. - destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). - inversion cor; contradict H; simpl; auto. -(* rewrite eq. (* inversion COR. *) (* inversion H. *) - - assert ((length b > 0)%nat). apply length_nonil. auto. - omega. - - destruct e; simpl; try omega. contradict H; simpl; auto. - *)Qed. - - -Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma no_header_size: - forall bb, size (no_header bb) = size bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. -Qed. - -Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma stick_header_size: - forall h bb, size (stick_header h bb) = size bb. -Proof. - intros. destruct bb. unfold stick_header. simpl. reflexivity. -Qed. - -Lemma stick_header_no_header: - forall bb, stick_header (header bb) (no_header bb) = bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. -Qed. - Definition bblocks := list bblock. @@ -689,103 +560,6 @@ Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. -Inductive instruction : Type := - | PBasic (i: basic) - | PControl (i: control) -. - -Coercion PBasic: basic >-> instruction. -Coercion PControl: control >-> instruction. - -Definition code := list instruction. -Definition bcode := list basic. - -Fixpoint basics_to_code (l: list basic) := - match l with - | nil => nil - | bi::l => (PBasic bi)::(basics_to_code l) - end. - -Fixpoint code_to_basics (c: code) := - match c with - | (PBasic i)::c => - match code_to_basics c with - | None => None - | Some l => Some (i::l) - end - | _::c => None - | nil => Some nil - end. - -Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. -Proof. - intros. induction c as [|i c]; simpl; auto. - rewrite IHc. auto. -Qed. - -Lemma code_to_basics_dist: - forall c c' l l', - code_to_basics c = Some l -> - code_to_basics c' = Some l' -> - code_to_basics (c ++ c') = Some (l ++ l'). -Proof. - induction c as [|i c]; simpl; auto. - - intros. inv H. simpl. auto. - - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. - inv H. erewrite IHc; eauto. auto. -Qed. - -(** - Asmblockgen will have to translate a Mach control into a list of instructions of the form - i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction - These functions provide way to extract the basic / control instructions -*) - -Fixpoint extract_basic (c: code) := - match c with - | nil => nil - | PBasic i :: c => i :: (extract_basic c) - | PControl i :: c => nil - end. - -Fixpoint extract_ctl (c: code) := - match c with - | nil => None - | PBasic i :: c => extract_ctl c - | PControl i :: nil => Some i - | PControl i :: _ => None (* if the first found control instruction isn't the last *) - end. - -(** * Utility for Asmblockgen *) - -Program Definition bblock_single_inst (i: instruction) := - match i with - | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} - | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} - end. -Next Obligation. - apply wf_bblock_refl. constructor. - right. discriminate. - constructor. -Qed. - -(** This definition is not used anymore *) -(* Program Definition bblock_basic_ctl (c: list basic) (i: option control) := - match i with - | Some i => {| header:=nil; body:=c; exit:=Some i |} - | None => - match c with - | _::_ => {| header:=nil; body:=c; exit:=None |} - | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} - end - end. -Next Obligation. - bblock_auto_correct. -Qed. Next Obligation. - bblock_auto_correct. -Qed. *) - - (** * Operational semantics *) (** The semantics operates over a single mapping from registers @@ -841,6 +615,8 @@ Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := Local Open Scope asm. +(** * Parallel Semantics of bundles *) + Section RELSEM. (** Execution of arith instructions *) @@ -855,10 +631,8 @@ Variable ge: genv. Inductive outcome: Type := | Next (rs:regset) (m:mem) - | Stuck. -(* Arguments outcome: clear implicits. *) - - + | Stuck +. (** ** Arithmetic Expressions (including comparisons) *) @@ -1216,22 +990,18 @@ 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) - end. + end. Definition arith_eval_arri32 n v1 v2 v3 := match n with | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) - end. + end. Definition arith_eval_arri64 n v1 v2 v3 := match n with | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) - end. + end. -(* TODO: on pourrait mettre ça dans Asmblock pour factoriser le code - en définissant - exec_arith_instr ai rs := parexec_arith_instr ai rs rs -*) Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := match ai with | PArithR n d => rsw#d <- (arith_eval_r n) @@ -1264,7 +1034,6 @@ Definition eval_offset (ofs: offset) : res ptrofs := (** * load/store *) -(* TODO: factoriser ? *) Definition parexec_load_offset (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 @@ -1321,11 +1090,8 @@ Definition store_chunk n := | Pfsd => Mfloat64 end. -(* rem: parexec_store = exec_store *) - (** * basic instructions *) -(* TODO: factoriser ? *) Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := match bi with | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw @@ -1381,15 +1147,7 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := end end. -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextblock]) or branching to a label ([goto_label]). *) - -(* TODO: factoriser ? *) -Definition par_nextblock size_b (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC size_b). - - -(** TODO: redundant w.r.t Machblock *) +(** TODO: redundant w.r.t Machblock ?? *) Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. Proof. apply List.in_dec. @@ -1423,7 +1181,6 @@ Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' end. -(* TODO: factoriser ? *) Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := match label_pos lbl 0 (fn_blocks f) with | None => Stuck @@ -1439,7 +1196,7 @@ Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) Warning: in m PC is assumed to be already pointing on the next instruction ! *) -(* TODO: factoriser ? *) + Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) (res: option bool) := match res with | Some true => par_goto_label f l rsr rsw mw @@ -1448,6 +1205,8 @@ Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) end. +(* FIXME: comment not up-to-date for parallel semantics *) + (** Execution of a single control-flow instruction [i] in initial state [rs] and [m]. Return updated state. @@ -1514,18 +1273,19 @@ Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) end. -Definition parexec_wio_bblock_aux (f: function) bdy ext size_b (rsr rsw: regset) (mr mw: mem): outcome := +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) + := 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 => - let rsr := par_nextblock size_b rsr in - parexec_control f ext rsr rsw mw + | Next rsw mw => parexec_exit f ext size_b rsr rsw mw | Stuck => Stuck end. -(** 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. - (** 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) /\ @@ -1534,30 +1294,19 @@ Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) ( | Stuck => Stuck end. -Lemma parexec_bblock_write_in_order f b rs m: - parexec_bblock f b rs m (parexec_wio_bblock f b rs m). -Proof. - exists (body b). exists nil. - constructor 1. - - rewrite app_nil_r; auto. - - unfold parexec_wio_bblock. - destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. -Qed. - (** deterministic parallel (out-of-order writes) execution of bundles *) Definition det_parexec (f: function) (bundle: bblock) (rs: regset) (m: mem) rs' m': Prop := forall o, parexec_bblock f bundle rs m o -> o = Next rs' m'. -Local Hint Resolve parexec_bblock_write_in_order. +(* FIXME: comment not up-to-date *) +(** Translation of the LTL/Linear/Mach view of machine registers to + the RISC-V view. Note that no LTL register maps to [X31]. This + register is reserved as temporary, to be used by the generated RV32G + code. *) -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'. -Proof. - unfold det_parexec; auto. -Qed. - (* FIXME - R16 and R32 are excluded *) +(* FIXME - R16 and R32 are excluded *) Definition preg_of (r: mreg) : preg := match r with | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 @@ -1584,7 +1333,7 @@ Definition undef_caller_save_regs (rs: regset) : regset := then rs r else Vundef. - +(* FIXME: comment not up-to-date *) (** Extract the values of the arguments of an external call. We exploit the calling conventions from module [Conventions], except that we use RISC-V registers instead of locations. *) @@ -1615,11 +1364,6 @@ Definition extcall_arguments Definition loc_external_result (sg: signature) : rpair preg := map_rpair preg_of (loc_result sg). -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextblock]) or branching to a label ([goto_label]). *) - -Definition nextblock (b:bblock) (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). (** Looking up bblocks in a code sequence by position. *) Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := @@ -1635,6 +1379,8 @@ Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := Inductive state: Type := | State: regset -> mem -> state. +Definition nextblock (b:bblock) (rs: regset) := + incrPC (Ptrofs.repr (size b)) rs. Inductive step: state -> trace -> state -> Prop := | exec_step_internal: @@ -1667,6 +1413,31 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') . + +(** 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. + + +Lemma parexec_bblock_write_in_order f b rs m: + parexec_bblock f b rs m (parexec_wio_bblock f b rs m). +Proof. + exists (body b). exists nil. + constructor 1. + - rewrite app_nil_r; auto. + - unfold parexec_wio_bblock. + destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. +Qed. + + +Local Hint Resolve parexec_bblock_write_in_order. + +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'. +Proof. + unfold det_parexec; auto. +Qed. + End RELSEM. (** Execution of whole programs. *) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 6e2539e3..8c68deea 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,4 +1,5 @@ open Asmvliw +open Asmblock open Printf open Camlcoq open InstructionScheduler diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 599a4024..f7ada92b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -226,7 +226,7 @@ Proof. repeat eexists. unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. - unfold exec_bblock. unfold nextblock. erewrite exec_body_pc_var; eauto. + unfold exec_bblock. unfold nextblock, incrPC. erewrite exec_body_pc_var; eauto. rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. assert (size bb = size a + size b). { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. @@ -234,8 +234,8 @@ Proof. clear EXA H0 H1. rewrite H in EXEB. assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } rewrite H0. rewrite <- pc_set_add; auto. - exploit AB.size_positive. instantiate (1 := a). intro. omega. - exploit AB.size_positive. instantiate (1 := b). intro. omega. + exploit size_positive. instantiate (1 := a). intro. omega. + exploit size_positive. instantiate (1 := b). intro. omega. Qed. Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : @@ -731,9 +731,9 @@ Proof. destruct bb as [h bdy ext H]; simpl. intros; subst. destruct i. generalize H. - rewrite <- AB.wf_bblock_refl in H. + rewrite <- wf_bblock_refl in H. destruct H as [H H0]. - unfold AB.builtin_alone in H0. erewrite H0; eauto. + unfold builtin_alone in H0. erewrite H0; eauto. Qed. Local Hint Resolve verified_schedule_nob_checks_alls_bundles. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 8a83521c..fa920a8c 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -1006,7 +1006,7 @@ Lemma exec_straight_through_singleinst: Proof. intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. simpl. auto. - simpl; auto. unfold nextblock; simpl. Simpl. erewrite exec_straight_pc; eauto. + simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. Qed. (** The following lemmas show that straight-line executions -- cgit From 6cf0154c1f00e0479c9bb1561944cb3b238a9e26 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 6 Apr 2019 09:07:17 +0200 Subject: no need for this to be in two_address_op --- mppa_k1c/Machregs.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index f36962f3..823b13e9 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -209,7 +209,7 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Ocast32unsigned | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => true + | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => true | _ => false end. -- cgit From 7b2b50c23765dd4c18f1afe3a1e2936d31a93fa2 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 7 Apr 2019 08:06:23 +0200 Subject: extract Machgen.trans_code stuff from Asmgenproof --- mppa_k1c/Asmgenproof.v | 79 ---------------------------------------- mppa_k1c/Machblockgenproof.v | 69 ++++++++++++++++++++++++++++++++--- mppa_k1c/lib/Asmblockgenproof0.v | 16 +------- 3 files changed, 65 insertions(+), 99 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 8eb0b693..b0e7619d 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -45,85 +45,6 @@ Qed. Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. - -(* TODO: put this proof in Machblocgen ? (it is specific to Machblocgen) *) -Lemma trans_code_monotonic c i b l: - trans_code c = b::l -> - exists l', exists b', trans_code (i::c) = l' ++ (b'::l). -Proof. - destruct c as [|i' c]. { rewrite trans_code_equation; intros; congruence. } - destruct (get_code_nature (i :: i':: c)) eqn:GCNIC. - - apply get_code_nature_empty in GCNIC. discriminate. - - (* i=label *) - destruct i; try discriminate. - rewrite! trans_code_equation; - remember (to_bblock (Mlabel l0 :: i' :: c)) as b0. - destruct b0 as [b0 c0]. - exploit to_bblock_label; eauto. - intros (H1 & H2). rewrite H2; simpl; clear H2. - intros H2; inversion H2; subst. - exists nil; simpl; eauto. - - (*i=basic *) - rewrite! trans_code_equation; destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. - destruct (cn_eqdec (get_code_nature (i':: c)) IsLabel). - + (* i'=label *) remember (to_bblock (i :: i' :: c)) as b1. - destruct b1 as [b1 c1]. - assert (X: c1 = i'::c). - { generalize Heqb1; clear Heqb1. - unfold to_bblock. - erewrite to_bblock_header_noLabel; try congruence. - destruct i'; try discriminate. - destruct i; try discriminate; simpl; - intro X; inversion X; auto. - } - subst c1. - rewrite !trans_code_equation. intro H1; rewrite H1. - exists (b1 :: nil). simpl; eauto. - + (* i'<>label *) remember (to_bblock (i :: i' :: c)) as b1. - destruct b1 as [b1 c1]. - remember (to_bblock (i' :: c)) as b2. - destruct b2 as [b2 c2]. - intro H1; assert (X: c1=c2). - { generalize Heqb1, Heqb2; clear Heqb1 Heqb2. - unfold to_bblock. - erewrite to_bblock_header_noLabel; try congruence. - destruct i'; simpl in * |- ; try congruence; - destruct i; try discriminate; simpl; - try (destruct (to_bblock_body c) as [xx yy], (to_bblock_exit yy); - intros X1 X2; inversion X1; inversion X2; auto). - } - subst; inversion H1. - exists nil; simpl; eauto. - - (* i=cfi *) - remember (to_cfi i) as cfi. - intros H. destruct cfi. - + erewrite trans_code_cfi; eauto. - rewrite H. - refine (ex_intro _ (_::nil) _). simpl; eauto. - + destruct i; simpl in * |-; try congruence. -Qed. - -Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> - exists b, (* Machblock.exit b = Some (Machblock.MBcall sg ros) /\ *) - is_tail (b :: trans_code c) (trans_code c2). -Proof. - intro H; induction 1. - - intros; subst. - rewrite (trans_code_equation (Mcall sg ros :: c)). - simpl. - eapply ex_intro; eauto with coqlib. - - intros; exploit IHis_tail; eauto. clear IHis_tail. - intros (b & Hb). - + inversion Hb; clear Hb. - * exploit (trans_code_monotonic c2 i); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - simpl; eauto with coqlib. - * exploit (trans_code_monotonic c2 i); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - simpl; eapply ex_intro. - eapply is_tail_trans; eauto with coqlib. -Qed. - Lemma return_address_exists: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> exists ra, return_address_offset f c ra. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 07ec9d08..11c3db6d 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -17,6 +17,11 @@ Require Import Machblock. Require Import Machblockgen. Require Import ForwardSimulationBlock. +Ltac subst_is_trans_code H := + rewrite is_trans_code_inv in H; + rewrite <- H in * |- *; + rewrite <- is_trans_code_inv in H. + Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := rao (transf_function f) (trans_code c). @@ -199,11 +204,6 @@ Definition concat (h: list label) (c: code): code := | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' end. -Ltac subst_is_trans_code H := - rewrite is_trans_code_inv in H; - rewrite <- H in * |- *; - rewrite <- is_trans_code_inv in H. - Lemma find_label_transcode_preserved: forall l c c', Mach.find_label l c = Some c' -> @@ -650,3 +650,62 @@ Proof. Qed. End PRESERVATION. + +(** Auxiliary lemmas used in [Asmgenproof.return_address_exists] *) + +Lemma is_trans_code_monotonic i c b l: + is_trans_code c (b::l) -> + exists l' b', is_trans_code (i::c) (l' ++ (b'::l)). +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. } + exists nil; simpl; eexists. eapply Tr_add_label; eauto. +Admitted. (* A FINIR *) + +Lemma trans_code_monotonic i c b l: + (b::l) = trans_code c -> + exists l' b', trans_code (i::c) = (l' ++ (b'::l)). +Proof. + intro H; rewrite <- is_trans_code_inv in H. + destruct (is_trans_code_monotonic i c b l H) as (l' & b' & H0). + subst_is_trans_code H0. + eauto. +Qed. + +(* FIXME: these two lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + +Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> + exists b, is_tail (b :: trans_code c) (trans_code c2). +Proof. + intros H; induction 1. + - intros; subst. + remember (trans_code (Mcall _ _::c)) as tc2. + rewrite <- is_trans_code_inv in Heqtc2. + inversion Heqtc2; simpl in * |- *; subst; try congruence. + subst_is_trans_code H1. + eapply ex_intro; eauto with coqlib. + - intros; exploit IHis_tail; eauto. clear IHis_tail. + intros (b & Hb). inversion Hb; clear Hb. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + exists b'; simpl; eauto with coqlib. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eapply ex_intro. + eapply is_tail_trans; eauto with coqlib. +Qed. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 443e8757..86c81c8d 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -14,6 +14,7 @@ Require Import Machblock. Require Import Asmblock. Require Import Asmblockgen. Require Import Conventions1. +Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) Module MB:=Machblock. Module AB:=Asmblock. @@ -571,21 +572,6 @@ Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : P transl_blocks f c false = OK tc -> code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. -(* NB: these two lemma should go into [Coqlib.v] *) -Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). -Proof. - induction l1; simpl; auto with coqlib. -Qed. -Hint Resolve is_tail_app: coqlib. - -Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. -Proof. - induction l1; simpl; auto with coqlib. - intros l2 l3 H; inversion H; eauto with coqlib. -Qed. -Hint Resolve is_tail_app_inv: coqlib. - - Lemma transl_blocks_tail: forall f c1 c2, is_tail c1 c2 -> forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> -- cgit From 0f974ca5d01323cbb3259e2be2ac6913f9873bdc Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 7 Apr 2019 22:32:17 +0200 Subject: cleaner separation between Asmgenproof and Machblockgenproof --- mppa_k1c/Asmgenproof.v | 11 ++++------- mppa_k1c/Machblockgenproof.v | 26 +++++++++++++++++++++++++- 2 files changed, 29 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index b0e7619d..85978cc9 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -42,17 +42,15 @@ Qed. (** Return Address Offset *) -Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. +Definition return_address_offset: Mach.function -> Mach.code -> ptrofs -> Prop := + Mach_return_address_offset Asmblockgenproof.return_address_offset. Lemma return_address_exists: forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> exists ra, return_address_offset f c ra. Proof. - intros. - exploit Mach_Machblock_tail; eauto. - destruct 1. - eapply Asmblockgenproof.return_address_exists; eauto. + intros; unfold return_address_offset; eapply Mach_return_address_exists; eauto. + intros; eapply Asmblockgenproof.return_address_exists; eauto. Qed. @@ -72,7 +70,6 @@ Proof. eapply compose_forward_simulations. exploit Machblockgenproof.transf_program_correct; eauto. unfold Machblockgenproof.inv_trans_rao. - intros X; apply X. eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. apply Asm.transf_program_correct. eauto. Qed. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 11c3db6d..e729a907 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -651,7 +651,9 @@ Qed. End PRESERVATION. -(** Auxiliary lemmas used in [Asmgenproof.return_address_exists] *) + + +(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) Lemma is_trans_code_monotonic i c b l: is_trans_code c (b::l) -> @@ -709,3 +711,25 @@ Proof. simpl; eapply ex_intro. eapply is_tail_trans; eauto with coqlib. Qed. + +Section Mach_Return_Address. + +Variable return_address_offset: function -> code -> ptrofs -> Prop. + +Hypothesis ra_exists: forall (b: bblock) (f: function) (c : list bblock), + is_tail (b :: c) (fn_code f) -> exists ra : ptrofs, return_address_offset f c ra. + +Definition Mach_return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := + return_address_offset (transf_function f) (trans_code c) ofs. + +Lemma Mach_return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, Mach_return_address_offset f c ra. +Proof. + intros. + exploit Mach_Machblock_tail; eauto. + destruct 1. + eapply ra_exists; eauto. +Qed. + +End Mach_Return_Address. \ No newline at end of file -- cgit From 374b62b878a3d8a7e4d00d81e1d69e89fba8886f Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 8 Apr 2019 13:32:40 +0200 Subject: improving comments on Asmvliw --- mppa_k1c/Asmvliw.v | 46 +++++++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 8620326f..7177d5fe 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -491,7 +491,15 @@ Coercion PExpand: ex_instruction >-> control. Coercion PCtlFlow: cf_instruction >-> control. -(** * Definition of a bblock (ie a bundle) *) +(** * Definition of a bblock (ie a bundle) + +A bundle/bblock must contain at least one instruction. + +This choice simplifies the definition of [find_bblock] below: +indeed, each address of a code block identifies at most one bundle +(which depends on the number of instructions in the bundles of lower addresses). + +*) Definition non_empty_body (body: list basic): bool := match body with @@ -544,7 +552,10 @@ Definition length_opt {A} (o: option A) : nat := (* WARNING: the notion of size is not the same than in Machblock ! We ignore labels here... - The result is in Z to be compatible with operations on PC + + This notion of size induces the notion of "valid" code address given by [find_bblock] + + The result is in Z to be compatible with operations on PC. *) Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). @@ -595,17 +606,7 @@ Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) end. -(* TODO: Is it still useful ?? *) - -(** Assigning multiple registers *) - -(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := - match rl, vl with - | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) - | _, _ => rs - end. - *) (** Assigning the result of a builtin *) Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := @@ -625,11 +626,22 @@ Section RELSEM. Variable ge: genv. -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [Next rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Stuck] if the processor is stuck. *) +(** The parallel semantics on bundles is purely small-step and defined as a relation + from the current state (a register set + a memory state) to either [Next rs' m'] + where [rs'] and [m'] are the updated register set and memory state after execution + of the instruction at [rs#PC], or [Stuck] if the processor is stuck. + + The parallel semantics of each instructions handles two states in input: + - the actual input state of the bundle which is only read + - and the other on which every "write" is performed: + it represents a temporary "writes" buffer, from which the final state + of the bundle is computed. + + NB: the sequential semantics defined in [Asmblock] is derived + from the parallel semantics of each instruction by identifying + the read state and the write state. + +*) Inductive outcome: Type := | Next (rs:regset) (m:mem) -- cgit From 5619eec808bdb9066c5e26b41956fc4534e103fa Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 8 Apr 2019 17:39:28 +0200 Subject: moving iandb from ImpCore to ImpPrelude --- mppa_k1c/abstractbb/Impure/ImpCore.v | 9 +-------- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 32 +++++++++++++++++--------------- 2 files changed, 18 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index 9745e35c..55e67608 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -185,11 +185,4 @@ Ltac wlp_xsimplify hint := Create HintDb wlp discriminated. -Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). - -(* impure lazy andb of booleans *) -Definition iandb (k1 k2: ??bool): ?? bool := - DO r1 <~ k1 ;; - if r1 then k2 else RET false. - -Extraction Inline iandb. (* Juste pour l'efficacité à l'extraction ! *) \ 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/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 8d904be6..0efa042c 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -6,10 +6,23 @@ Require Import BinNums. Require Export ImpCore. Require Export PArith. + +Import Notations. +Local Open Scope impure. + +(** Impure lazy andb of booleans *) +Definition iandb (k1 k2: ??bool): ?? bool := + DO r1 <~ k1 ;; + if r1 then k2 else RET false. + +Extraction Inline iandb. (* Juste pour l'efficacité à l'extraction ! *) + +(** Strings for pretty-printing *) + Axiom caml_string: Type. Extract Constant caml_string => "string". -(** New line *) +(* New line *) Definition nl: string := String (ascii_of_pos 10%positive) EmptyString. Inductive pstring: Type := @@ -25,9 +38,6 @@ Notation "x +; y" := (Concat x y) (** Coq references *) -Import Notations. -Local Open Scope impure. - Record cref {A} := { set: A -> ?? unit; get: unit -> ?? A @@ -52,20 +62,15 @@ Extract Constant count_logger => "(fun () -> let count = ref 0 in { log_insert = (** Axioms of Physical equality *) -Module Type PhysEq. - Axiom phys_eq: forall {A}, A -> A -> ?? bool. Axiom phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. -End PhysEq. - - (* We only check here that above axioms are not trivially inconsistent... (but this does not prove the correctness of the extraction directive below). *) -Module PhysEqModel: PhysEq. +Module PhysEqModel. Definition phys_eq {A} (x y: A) := ret false. @@ -76,16 +81,13 @@ Qed. End PhysEqModel. - -Export PhysEqModel. - -Extract Constant phys_eq => "(==)". +Extract Inlined Constant phys_eq => "(==)". Hint Resolve phys_eq_correct: wlp. Axiom struct_eq: forall {A}, A -> A -> ?? bool. Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN if b then x=y else x<>y. -Extract Constant struct_eq => "(=)". +Extract Inlined Constant struct_eq => "(=)". Hint Resolve struct_eq_correct: wlp. -- cgit From 049c3f1a34e5af8d9c59b54bd3270dca863f5366 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 9 Apr 2019 16:31:45 +0200 Subject: Fixing missing features in Asmexpand.ml (EF_annot, EF_annot_val, EF_inline_asm) --- mppa_k1c/Asmexpand.ml | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 6310b8ae..d12b9785 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -111,16 +111,13 @@ let fixup_call sg = (* Handling of annotations *) -let expand_annot_val kind txt targ args res = assert false -(*emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); +let expand_annot_val kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); match args, res with - | [BA(IR src)], BR(IR dst) -> + | [BA(Asmvliw.IR src)], BR(Asmvliw.IR dst) -> if dst <> src then emit (Pmv (dst, src)) - | [BA(FR src)], BR(FR dst) -> - if dst <> src then emit (Pfmv (dst, src)) | _, _ -> raise (Error "ill-formed __builtin_annot_val") -*) (* Handling of memcpy *) @@ -465,10 +462,10 @@ let expand_instruction instr = | EF_malloc -> failwith "asmexpand: malloc" | EF_free -> failwith "asmexpand: free" | EF_debug _ -> failwith "asmexpand: debug" - | EF_annot _ -> failwith "asmexpand: annot" - | EF_annot_val _ -> failwith "asmexpand: annot_val" + | EF_annot _ -> emit instr + | EF_annot_val (kind, txt, targ) -> expand_annot_val kind txt targ args res | EF_external _ -> failwith "asmexpand: external" - | EF_inline_asm _ -> failwith "asmexpand: inline asm" + | EF_inline_asm _ -> emit instr | EF_runtime _ -> failwith "asmexpand: runtime" end | _ -> -- cgit From f9903c892361584116de323111a0070fedbd3fff Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 10 Apr 2019 18:37:15 +0200 Subject: achieve issue #89 ? --- mppa_k1c/Asmblockdeps.v | 232 ++++++++++-------------------------------------- 1 file changed, 47 insertions(+), 185 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 18aeafac..402e3178 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1689,7 +1689,7 @@ Proof. destruct (ireg_eq g rd); subst; Simpl. Qed. -Theorem forward_simu_par_wio_basic_gen ge fn rsr rsw mr mw sr sw bi: +Theorem forward_simu_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 -> @@ -1763,55 +1763,22 @@ Proof. Qed. -Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi rsw' mw': - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_basic_instr ge bi rsr rsw mr mw = Next rsw' mw' -> - exists sw', - inst_prun Ge (trans_basic bi) sw sr sr = Some sw' - /\ match_states (State rsw' mw') sw'. -Proof. - intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. - simpl; auto. -Qed. - -Theorem forward_simu_par_wio_basic_Stuck 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 -> - parexec_basic_instr ge bi rsr rsw mr mw = Stuck -> - inst_prun Ge (trans_basic bi) sw sr sr = None. -Proof. - intros H H0 H1 H2; exploit forward_simu_par_wio_basic_gen; [ eapply H | eapply H0 | eapply H1 | erewrite H2 ]. - simpl; auto. -Qed. - Theorem forward_simu_par_body: - forall bdy ge fn rsr mr sr rsw mw sw rs' m', + forall bdy ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_wio_body ge bdy rsr rsw mr mw = Next rs' m' -> - exists s', - prun_iw Ge (trans_body bdy) sw sr = Some s' - /\ match_states (State rs' m') s'. + match_outcome (parexec_wio_body ge bdy rsr rsw mr mw) (prun_iw Ge (trans_body bdy) sw sr). Proof. - induction bdy. - - intros until m'. intros GENV MSR MSW WIO. - simpl in WIO. inv WIO. inv MSR. inv MSW. - eexists. split; [| split]. - * simpl. reflexivity. - * assumption. - * assumption. - - intros until m'. intros GENV MSR MSW WIO. - simpl in WIO. destruct (parexec_basic_instr _ _ _ _ _ _) eqn:PARBASIC; try discriminate. - exploit forward_simu_par_wio_basic. 4: eapply PARBASIC. all: eauto. - intros (sw' & MPRUN & MS'). simpl prun_iw. rewrite MPRUN. - eapply IHbdy; eauto. + 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. + - intros (s' & X1 & X2). rewrite X1; simpl; eauto. + - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_par_control_gen ge fn rsr rsw mr mw sr sw sz ex: +Theorem forward_simu_par_control 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 -> @@ -1869,116 +1836,44 @@ Proof. intros rr; destruct rr; unfold incrPC; Simpl. Qed. -Theorem forward_simu_par_control ge fn rsr rsw mr mw sr sw sz rs' ex m': - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw = Next rs' m' -> - exists s', - inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = Some s' - /\ match_states (State rs' m') s'. -Proof. - intros. exploit forward_simu_par_control_gen. 3: eapply H1. 2: eapply H0. all: eauto. - intros. erewrite H2 in H3. inv H3. eexists. - eapply H4. -Qed. - -Lemma forward_simu_par_control_Stuck ge fn rsr rsw mr mw sr sw sz ex: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw = Stuck -> - inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr = None. -Proof. - intros. exploit forward_simu_par_control_gen. 3: eapply H1. 2: eapply H0. all: eauto. - intros. erewrite H2 in H3. inv H3. unfold trans_pcincr. unfold inst_prun. unfold exp_eval. unfold op_eval. destruct (control_eval _ _ _); 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 rs' m': +Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr rsw mr mw = Next rs' m' -> - exists s', - prun_iw Ge (trans_block_aux bdy sz ex) sw sr = Some s' - /\ match_states (State rs' m') s'. + 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). Proof. - intros. unfold parexec_wio_bblock_aux in H2. unfold trans_block_aux. - destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB; try discriminate. - exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. - intros (s' & RUNB & MS'). - exploit forward_simu_par_control. 4: eapply H2. all: eauto. - intros (s'' & RUNCTL & MS''). - eexists. split. - erewrite prun_iw_app_Some; eauto. unfold prun_iw. rewrite RUNCTL. reflexivity. eassumption. -Qed. - -Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz rs' m' rs2 m2: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw = Next rs' m' -> - parexec_wio_body ge bdy2 rsr rs' mr m' = Next rs2 m2 -> - exists s2', - prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sw sr = Some s2' - /\ match_states (State rs2 m2) s2'. -Proof. - intros. exploit forward_simu_par_wio_bblock_aux. 4: eapply H2. all: eauto. - intros (s' & RUNAUX & MS'). - exploit forward_simu_par_body. 4: eapply H3. all: eauto. - intros (s'' & RUNBDY2 & MS''). - eexists. split. - erewrite prun_iw_app_Some; eauto. eassumption. + intros H H0 H1. unfold parexec_wio_bblock_aux, trans_block_aux. + exploit (forward_simu_par_body bdy ge fn rsr mr sr rsw mw sw); eauto. + destruct (parexec_wio_body _ _ _ _ _ _); simpl. + - intros (s' & X1 & X2). + erewrite prun_iw_app_Some; eauto. + unfold parexec_exit. + exploit (forward_simu_par_control ex sz ge fn rsr rs mr m sr s'); eauto. + subst Ge; simpl. destruct H0 as (Y1 & Y2). erewrite Y2; simpl. + destruct (inst_prun _ _ _ _ _); simpl; auto. + - intros X; erewrite prun_iw_app_None; eauto. Qed. -Lemma forward_simu_par_body_Stuck bdy: forall ge fn rsr mr sr rsw mw sw, +Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - parexec_wio_body ge bdy rsr rsw mr mw = Stuck -> - prun_iw Ge (trans_body bdy) sw sr = None. -Proof. - induction bdy. - - intros until sw. intros GENV MSR MSW WIO. - simpl in WIO. inv WIO. - - intros until sw. intros GENV MSR MSW WIO. - simpl in WIO. destruct (parexec_basic_instr _ _ _ _ _ _) eqn:PARBASIC. - * exploit forward_simu_par_wio_basic. 4: eapply PARBASIC. all: eauto. - intros (sw' & MPRUN & MS'). simpl prun_iw. rewrite MPRUN. - eapply IHbdy; eauto. - * exploit forward_simu_par_wio_basic_Stuck. 4: eapply PARBASIC. all: eauto. - intros X; simpl; rewrite X; auto. -Qed. - -Lemma forward_simu_par_wio_stuck_bdy1 ge fn rs m s1' bdy1 sz ex: - Ge = Genv ge fn -> - match_states (State rs m) s1' -> - parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rs rs m m = Stuck -> - prun_iw Ge ((trans_block_aux bdy1 sz ex)) s1' s1' = None. + match_outcome + match parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw 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). Proof. - unfold parexec_wio_bblock_aux, trans_block_aux; intros. - destruct (parexec_wio_body _ _ _ _ _ _) eqn:WIOB. - * exploit forward_simu_par_body. 4: eapply WIOB. all: eauto. - intros (s' & RUNB & MS'). + intros H H0 H1. + 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. + - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. - exploit forward_simu_par_control_Stuck. 4: eauto. all: eauto. - simpl. intros X; rewrite X. auto. - * apply prun_iw_app_None. eapply forward_simu_par_body_Stuck. 4: eauto. all: eauto. -Qed. - -Lemma forward_simu_par_wio_stuck_bdy2 ge fn rs m s1' bdy1 bdy2 sz ex m' rs': - Ge = Genv ge fn -> - match_states (State rs m) s1' -> - parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rs rs m m = Next rs' m' -> - parexec_wio_body ge bdy2 rs rs' m m' = Stuck -> - prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) s1' s1'=None. -Proof. - intros; exploit forward_simu_par_wio_bblock_aux. 4: eauto. all: eauto. - intros (s2' & X1 & X2). - erewrite prun_iw_app_Some; eauto. - eapply forward_simu_par_body_Stuck. 4: eauto. all: eauto. + eapply forward_simu_par_body; eauto. + - intros X; erewrite prun_iw_app_None; eauto. Qed. Lemma trans_body_perserves_permutation bdy1 bdy2: @@ -2008,45 +1903,7 @@ Proof. apply Permutation_app_comm. Qed. -Theorem forward_simu_par: - forall rs1 m1 s1' b ge fn rs2 m2, - Ge = Genv ge fn -> - parexec_bblock ge fn b rs1 m1 (Next rs2 m2) -> - match_states (State rs1 m1) s1' -> - exists s2', - prun Ge (trans_block b) s1' (Some s2') - /\ match_states (State rs2 m2) s2'. -Proof. - intros until m2. intros GENV PAREXEC MS. - inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). - exploit trans_block_perserves_permutation; eauto. - intros Perm. - remember (parexec_wio_bblock_aux _ _ _ _ _ _ _ _ _) as pwb. - destruct pwb; try congruence. - exploit forward_simu_par_wio_bblock; eauto. intros (s2' & PIW & MS'). - unfold prun; simpl; eexists; split; eauto. -Qed. - -Theorem forward_simu_par_stuck: - forall rs1 m1 s1' b ge fn, - Ge = Genv ge fn -> - parexec_bblock ge fn b rs1 m1 Stuck -> - match_states (State rs1 m1) s1' -> - prun Ge (trans_block b) s1' None. -Proof. - intros until fn. intros GENV PAREXEC MS. - inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). - exploit trans_block_perserves_permutation; eauto. - intros Perm. - destruct (parexec_wio_bblock_aux _ _ _ _ _ _ _ _) eqn:WIOEXIT. - - econstructor; eauto. split. eapply forward_simu_par_wio_stuck_bdy2; eauto. auto. - - clear WIO. econstructor; eauto. split; eauto. - simpl; apply prun_iw_app_None; auto. - eapply forward_simu_par_wio_stuck_bdy1; eauto. -Qed. - -Theorem forward_simu_par_alt: - forall rs1 m1 s1' b ge fn o2, +Theorem forward_simu_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 -> @@ -2054,13 +1911,18 @@ Theorem forward_simu_par_alt: prun Ge (trans_block b) s1' o2' /\ match_outcome o2 o2'. Proof. - intros until o2. intros GENV MS PAREXEC. destruct o2 eqn:O2. - - exploit forward_simu_par; eauto. intros (s2' & PRUN & MS'). eexists. split. eassumption. - unfold match_outcome. eexists; split; auto. - - exploit forward_simu_par_stuck; eauto. intros. eexists; split; eauto. - constructor; auto. + intros GENV MS PAREXEC. + 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. + rewrite <- WIO. clear WIO. + intros H; eexists; split. 2: eapply H. + unfold prun; eexists; split; eauto. + destruct (prun_iw _ _ _ _); simpl; eauto. Qed. + Lemma bblock_para_check_correct ge fn bb rs m rs' m': Ge = Genv ge fn -> exec_bblock ge fn bb rs m = Next rs' m' -> @@ -2070,7 +1932,7 @@ Proof. intros H H0 H1 o H2. unfold bblock_para_check in H1. exploit forward_simu; eauto. eapply trans_state_match. intros (s2' & EXEC & MS). - exploit forward_simu_par_alt. 2: apply (trans_state_match (State rs m)). all: eauto. + exploit forward_simu_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'. -- cgit From 7cc001e63990ae5e8cf2f75b5148093e31fbdc85 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 10 Apr 2019 22:50:06 +0200 Subject: get / set k1 --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmexpand.ml | 5 +++++ mppa_k1c/CBuiltins.ml | 5 ++++- mppa_k1c/Machregs.v | 5 ++++- mppa_k1c/TargetPrinter.ml | 8 +++++++- 5 files changed, 23 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 303a624c..7c6bd013 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -72,7 +72,10 @@ Inductive instruction : Type := | 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) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d12b9785..d4792541 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -357,6 +357,11 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pclzll(res, a)) | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pstsud(res, a1, a2)) + | "__builtin_k1_get", [BA_int(n)], BR(IR res) -> + emit (Pgetn(n, res)) + | "__builtin_k1_set", [BA_int(n); BA(IR src)], _ -> + emit (Psetn(n, src)) + (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> expand_bswap16 res a1 diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 147bbb55..9d0c607d 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -38,7 +38,10 @@ let builtins = { "__builtin_k1_stop", (TVoid [], [], false); "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); "__builtin_k1_tlbwrite", (TVoid [], [], false); - + + "__builtin_k1_get", (TInt(IULong, []), [TInt(IUInt, [])], false); + "__builtin_k1_set", (TVoid [], [TInt(IUInt, []); TInt(IULong, [])], false); + (* LSU Instructions *) (* No ACWS - __int128 *) "__builtin_k1_afda", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 823b13e9..f9712428 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -218,7 +218,10 @@ Definition two_address_op (op: operation) : bool := Definition builtin_constraints (ef: external_function) : list builtin_arg_constraint := match ef with - | EF_builtin id sg => nil + | EF_builtin id sg => + if string_dec id "__builtin_k1_get" then OK_const :: nil + else if string_dec id "__builtin_k1_set" then OK_const :: OK_default :: nil + else nil | EF_vload _ => OK_addressing :: nil | EF_vstore _ => OK_addressing :: OK_default :: nil | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3aa6b319..beac8cfe 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -274,8 +274,14 @@ module Target (*: TARGET*) = fprintf oc " goto %a\n" print_label s | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl + | Ploopdo (r, lbl) -> - fprintf oc " loopdo %a, %a\n" ireg r print_label lbl + fprintf oc " loopdo %a, %a\n" ireg r print_label lbl + | Pgetn(n, dst) -> + fprintf oc " get %a = $s%ld\n" ireg dst (camlint_of_coqint n) + | Psetn(n, dst) -> + fprintf oc " set $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in (* jumptables := (lbl, tbl) :: !jumptables; *) -- cgit From 696d150a5ec5387e78b2aae941a77a190af58562 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 05:49:50 +0200 Subject: __builtin_k1_get and __builtin_k1_set with safeguards, work for clock --- mppa_k1c/Asmexpand.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d4792541..2997bc8b 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -344,7 +344,8 @@ let expand_bswap64 d s = assert false *) (* Handling of compiler-inlined builtins *) - +let last_system_register = 511l + let expand_builtin_inline name args res = let open Asmvliw in match name, args, res with (* Synchronization *) @@ -358,9 +359,15 @@ let expand_builtin_inline name args res = let open Asmvliw in | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pstsud(res, a1, a2)) | "__builtin_k1_get", [BA_int(n)], BR(IR res) -> - emit (Pgetn(n, res)) + let cn = camlint_of_coqint n in + (if cn<0l || cn>last_system_register + then failwith (Printf.sprintf "__builtin_k1_get(n): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pgetn(n, res))) | "__builtin_k1_set", [BA_int(n); BA(IR src)], _ -> - emit (Psetn(n, src)) + let cn = camlint_of_coqint n in + (if cn<0l || cn>last_system_register + then failwith (Printf.sprintf "__builtin_k1_set(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Psetn(n, src))) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> -- cgit From 466767d23cbc816b5787e6768e5f9a98a95abca9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 08:08:26 +0200 Subject: fix types for k1 builtins --- mppa_k1c/CBuiltins.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 9d0c607d..e5cdcd01 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -39,8 +39,8 @@ let builtins = { "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); "__builtin_k1_tlbwrite", (TVoid [], [], false); - "__builtin_k1_get", (TInt(IULong, []), [TInt(IUInt, [])], false); - "__builtin_k1_set", (TVoid [], [TInt(IUInt, []); TInt(IULong, [])], false); + "__builtin_k1_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); + "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* LSU Instructions *) (* No ACWS - __int128 *) -- cgit From cdb5ec57d700c5409c0717bb99258a5effed9601 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 09:28:59 +0200 Subject: wfxl / wfxm --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmexpand.ml | 17 ++++++++++++++--- mppa_k1c/CBuiltins.ml | 1 - mppa_k1c/Machregs.v | 9 +++++++-- mppa_k1c/TargetPrinter.ml | 4 ++++ 5 files changed, 27 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 7c6bd013..9517099c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -76,6 +76,8 @@ Inductive instruction : Type := | 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) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 2997bc8b..1bf99768 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -345,7 +345,8 @@ let expand_bswap64 d s = assert false (* Handling of compiler-inlined builtins *) let last_system_register = 511l - +let not_system_register cn =cn<0l || cn>last_system_register + let expand_builtin_inline name args res = let open Asmvliw in match name, args, res with (* Synchronization *) @@ -360,14 +361,24 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pstsud(res, a1, a2)) | "__builtin_k1_get", [BA_int(n)], BR(IR res) -> let cn = camlint_of_coqint n in - (if cn<0l || cn>last_system_register + (if not_system_register cn then failwith (Printf.sprintf "__builtin_k1_get(n): n must be between 0 and %ld, was %ld" last_system_register cn) else emit (Pgetn(n, res))) | "__builtin_k1_set", [BA_int(n); BA(IR src)], _ -> let cn = camlint_of_coqint n in - (if cn<0l || cn>last_system_register + (if not_system_register cn then failwith (Printf.sprintf "__builtin_k1_set(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) else emit (Psetn(n, src))) + | "__builtin_k1_wfxl", [BA_int(n); BA(IR src)], _ -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_k1_wfxl(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pwfxl(n, src))) + | "__builtin_k1_wfxm", [BA_int(n); BA(IR src)], _ -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_k1_wfxm(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pwfxm(n, src))) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index e5cdcd01..f9eec191 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -27,7 +27,6 @@ let builtins = { "__builtin_k1_await", (TVoid [], [], false); "__builtin_k1_barrier", (TVoid [], [], false); "__builtin_k1_doze", (TVoid [], [], false); - (* No __builtin_k1_get - not compatible with the Asm model *) "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); "__builtin_k1_invaldtlb", (TVoid [], [], false); diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index f9712428..61f9089f 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -220,8 +220,13 @@ Definition builtin_constraints (ef: external_function) : match ef with | EF_builtin id sg => if string_dec id "__builtin_k1_get" then OK_const :: nil - else if string_dec id "__builtin_k1_set" then OK_const :: OK_default :: nil - else nil + else if string_dec id "__builtin_k1_set" + then OK_const :: OK_default :: nil + else if string_dec id "__builtin_k1_wfxl" + then OK_const :: OK_default :: nil + else if string_dec id "__builtin_k1_wfxm" + then OK_const :: OK_default :: nil + else nil | EF_vload _ => OK_addressing :: nil | EF_vstore _ => OK_addressing :: OK_default :: nil | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index beac8cfe..af1c5581 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -281,6 +281,10 @@ module Target (*: TARGET*) = fprintf oc " get %a = $s%ld\n" ireg dst (camlint_of_coqint n) | Psetn(n, dst) -> fprintf oc " set $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pwfxl(n, dst) -> + fprintf oc " wfxl $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pwfxm(n, dst) -> + fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in -- cgit From e93ef3ef5f0925ce6b99208157a49a99032c1f87 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 11:57:09 +0200 Subject: __builtin_k1_ldu --- mppa_k1c/Asm.v | 6 ++++-- mppa_k1c/Asmexpand.ml | 4 +++- mppa_k1c/CBuiltins.ml | 10 +++++----- mppa_k1c/TargetPrinter.ml | 5 ++++- 4 files changed, 16 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 9517099c..26c6cc02 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -72,13 +72,15 @@ Inductive instruction : Type := | 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) + (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1bf99768..bcc2d28f 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -379,7 +379,9 @@ let expand_builtin_inline name args res = let open Asmvliw in (if not_system_register cn then failwith (Printf.sprintf "__builtin_k1_wfxm(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) else emit (Pwfxm(n, src))) - + | "__builtin_k1_ldu", [BA(IR addr)], BR(IR res) -> + emit (Pldu(res, addr)) + (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> expand_bswap16 res a1 diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index f9eec191..0de6d0c7 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -27,8 +27,8 @@ let builtins = { "__builtin_k1_await", (TVoid [], [], false); "__builtin_k1_barrier", (TVoid [], [], false); "__builtin_k1_doze", (TVoid [], [], false); - "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); - "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); + "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) + "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) "__builtin_k1_invaldtlb", (TVoid [], [], false); "__builtin_k1_invalitlb", (TVoid [], [], false); "__builtin_k1_probetlb", (TVoid [], [], false); @@ -38,8 +38,8 @@ let builtins = { "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); "__builtin_k1_tlbwrite", (TVoid [], [], false); - "__builtin_k1_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); - "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); + "__builtin_k1_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); (* DONE *) + "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) (* LSU Instructions *) (* No ACWS - __int128 *) @@ -55,7 +55,7 @@ let builtins = { "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); "__builtin_k1_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); "__builtin_k1_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_lhsu", (TInt(IShort, []), [TPtr(TVoid [], [])], false); "__builtin_k1_lhzu", (TInt(IUShort, []), [TPtr(TVoid [], [])], false); "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index af1c5581..b2a9e827 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -275,6 +275,7 @@ module Target (*: TARGET*) = | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl + (* For builtins *) | Ploopdo (r, lbl) -> fprintf oc " loopdo %a, %a\n" ireg r print_label lbl | Pgetn(n, dst) -> @@ -285,7 +286,9 @@ module Target (*: TARGET*) = fprintf oc " wfxl $s%ld = %a\n" (camlint_of_coqint n) ireg dst | Pwfxm(n, dst) -> fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst - + | Pldu(dst, addr) -> + fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr + | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in (* jumptables := (lbl, tbl) :: !jumptables; *) -- cgit From 71bfa128316019b0199db87acdf31deb9f9e7405 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 12:14:33 +0200 Subject: some more builtins --- mppa_k1c/Asm.v | 5 +++++ mppa_k1c/Asmexpand.ml | 10 ++++++++++ mppa_k1c/CBuiltins.ml | 10 +++++----- mppa_k1c/TargetPrinter.ml | 10 ++++++++++ 4 files changed, 30 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 26c6cc02..55138a3f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -80,6 +80,11 @@ Inductive instruction : Type := | Pwfxl (n: int) (src: ireg) | Pwfxm (n: int) (src: ireg) | Pldu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index bcc2d28f..e09492e9 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -381,6 +381,16 @@ let expand_builtin_inline name args res = let open Asmvliw in else emit (Pwfxm(n, src))) | "__builtin_k1_ldu", [BA(IR addr)], BR(IR res) -> emit (Pldu(res, addr)) + | "__builtin_k1_await", [], _ -> + emit Pawait + | "__builtin_k1_sleep", [], _ -> + emit Psleep + | "__builtin_k1_stop", [], _ -> + emit Pstop + | "__builtin_k1_barrier", [], _ -> + emit Pbarrier + | "__builtin_k1_fence", [], _ -> + emit Pfence (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 0de6d0c7..e4652d77 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -24,8 +24,8 @@ let builtins = { (* 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?) *) (* BCU Instructions *) - "__builtin_k1_await", (TVoid [], [], false); - "__builtin_k1_barrier", (TVoid [], [], false); + "__builtin_k1_await", (TVoid [], [], false); (* DONE *) + "__builtin_k1_barrier", (TVoid [], [], false); (* DONE *) "__builtin_k1_doze", (TVoid [], [], false); "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) @@ -33,8 +33,8 @@ let builtins = { "__builtin_k1_invalitlb", (TVoid [], [], false); "__builtin_k1_probetlb", (TVoid [], [], false); "__builtin_k1_readtlb", (TVoid [], [], false); - "__builtin_k1_sleep", (TVoid [], [], false); - "__builtin_k1_stop", (TVoid [], [], false); + "__builtin_k1_sleep", (TVoid [], [], false); (* DONE *) + "__builtin_k1_stop", (TVoid [], [], false); (* DONE *) "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); "__builtin_k1_tlbwrite", (TVoid [], [], false); @@ -49,7 +49,7 @@ let builtins = { "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); - "__builtin_k1_fence", (TVoid [], [], false); + "__builtin_k1_fence", (TVoid [], [], false); (* DONE *) "__builtin_k1_iinval", (TVoid [], [], false); "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index b2a9e827..c67792e7 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -288,6 +288,16 @@ module Target (*: TARGET*) = fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst | Pldu(dst, addr) -> fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr + | Pawait -> + fprintf oc " await\n" + | Psleep -> + fprintf oc " sleep\n" + | Pstop -> + fprintf oc " stop\n" + | Pbarrier -> + fprintf oc " barrier\n" + | Pfence -> + fprintf oc " fence\n" | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in -- cgit From 9ff90aa440d195076a30fe4d8a055d050d84f726 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 13:11:13 +0200 Subject: data cache builtins --- mppa_k1c/Asm.v | 4 ++++ mppa_k1c/Asmexpand.ml | 8 ++++++++ mppa_k1c/CBuiltins.ml | 10 +++++----- mppa_k1c/TargetPrinter.ml | 8 ++++++++ 4 files changed, 25 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 55138a3f..bb78eda1 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -85,6 +85,10 @@ Inductive instruction : Type := | Pstop | Pbarrier | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Pdzerol (addr: ireg) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index e09492e9..97a85881 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -391,6 +391,14 @@ let expand_builtin_inline name args res = let open Asmvliw in emit Pbarrier | "__builtin_k1_fence", [], _ -> emit Pfence + | "__builtin_k1_dinval", [], _ -> + emit Pdinval + | "__builtin_k1_dinvall", [BA(IR addr)], _ -> + emit (Pdinvall addr) + | "__builtin_k1_dtouchl", [BA(IR addr)], _ -> + emit (Pdtouchl addr) + | "__builtin_k1_dzerol", [BA(IR addr)], _ -> + emit (Pdzerol addr) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index e4652d77..56412d71 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -26,7 +26,7 @@ let builtins = { (* BCU Instructions *) "__builtin_k1_await", (TVoid [], [], false); (* DONE *) "__builtin_k1_barrier", (TVoid [], [], false); (* DONE *) - "__builtin_k1_doze", (TVoid [], [], false); + "__builtin_k1_doze", (TVoid [], [], false); (* opcode not supported in assembly, not in documentation *) "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) "__builtin_k1_invaldtlb", (TVoid [], [], false); @@ -45,10 +45,10 @@ let builtins = { (* No ACWS - __int128 *) "__builtin_k1_afda", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); "__builtin_k1_aldc", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_dinval", (TVoid [], [], false); - "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); - "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); - "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) + "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_fence", (TVoid [], [], false); (* DONE *) "__builtin_k1_iinval", (TVoid [], [], false); "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index c67792e7..fc4d6ba6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -298,6 +298,14 @@ module Target (*: TARGET*) = fprintf oc " barrier\n" | Pfence -> fprintf oc " fence\n" + | Pdinval -> + fprintf oc " dinval\n" + | Pdinvall addr -> + fprintf oc " dinvall 0[%a]\n" ireg addr + | Pdtouchl addr -> + fprintf oc " dtouchl 0[%a]\n" ireg addr + | Pdzerol addr -> + fprintf oc " dzerol 0[%a]\n" ireg addr | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in -- cgit From 133728dcd0c9d27965b519e8b18e7bca4fd8c473 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 13:17:40 +0200 Subject: instruction cache builtins --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmexpand.ml | 6 ++++++ mppa_k1c/CBuiltins.ml | 6 +++--- mppa_k1c/TargetPrinter.ml | 6 ++++++ 4 files changed, 18 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index bb78eda1..b5051de3 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -88,6 +88,9 @@ Inductive instruction : Type := | Pdinval | Pdinvall (addr: ireg) | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) | Pdzerol (addr: ireg) (** Loads **) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 97a85881..c4e73b76 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -397,6 +397,12 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pdinvall addr) | "__builtin_k1_dtouchl", [BA(IR addr)], _ -> emit (Pdtouchl addr) + | "__builtin_k1_iinval", [], _ -> + emit Piinval + | "__builtin_k1_iinvals", [BA(IR addr)], _ -> + emit (Piinvals addr) + | "__builtin_k1_itouchl", [BA(IR addr)], _ -> + emit (Pitouchl addr) | "__builtin_k1_dzerol", [BA(IR addr)], _ -> emit (Pdzerol addr) diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 56412d71..1490d94f 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -50,9 +50,9 @@ let builtins = { "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_fence", (TVoid [], [], false); (* DONE *) - "__builtin_k1_iinval", (TVoid [], [], false); - "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); - "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_iinval", (TVoid [], [], false); (* DONE *) + "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE [not supported by assembler but in documentation] *) "__builtin_k1_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); "__builtin_k1_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index fc4d6ba6..7b22a857 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -304,6 +304,12 @@ module Target (*: TARGET*) = fprintf oc " dinvall 0[%a]\n" ireg addr | Pdtouchl addr -> fprintf oc " dtouchl 0[%a]\n" ireg addr + | Piinval -> + fprintf oc " iinval\n" + | Piinvals addr -> + fprintf oc " iinvals 0[%a]\n" ireg addr + | Pitouchl addr -> + fprintf oc " itouchl 0[%a]\n" ireg addr | Pdzerol addr -> fprintf oc " dzerol 0[%a]\n" ireg addr -- cgit From 0e5f7395d185cde931c11fb3a12e6c2af03a7ebf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 14:20:47 +0200 Subject: afaddd / afaddw --- mppa_k1c/Asm.v | 2 ++ mppa_k1c/Asmexpand.ml | 8 ++++++++ mppa_k1c/CBuiltins.ml | 6 +++--- mppa_k1c/Machregs.v | 1 + mppa_k1c/TargetPrinter.ml | 4 ++++ 5 files changed, 18 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b5051de3..a9a88d75 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -92,6 +92,8 @@ Inductive instruction : Type := | Piinvals (addr: ireg) | Pitouchl (addr: ireg) | Pdzerol (addr: ireg) + | Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index c4e73b76..872a29f5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -405,6 +405,14 @@ 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) -> + (if res <> incr_res + then (emit (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)) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 1490d94f..9fe5c958 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -42,9 +42,9 @@ let builtins = { "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) (* LSU Instructions *) - (* No ACWS - __int128 *) - "__builtin_k1_afda", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); - "__builtin_k1_aldc", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + (* No ACWS - __int128 *) + "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 61f9089f..06758756 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -184,6 +184,7 @@ Definition mregs_for_operation (op: operation): list (option mreg) * option mreg (* FIXME DMonniaux this seems to be the place for preferred registers for arguments *) Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). + (* match ef with | EF_builtin name sg => if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 7b22a857..4599f2a1 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -312,6 +312,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 + | Pafaddw(addr, incr_res) -> + fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in -- cgit From 4807d6f32f08dd70f798a0478d39163ad3b81129 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 11 Apr 2019 14:20:56 +0200 Subject: refactor for #92 --- mppa_k1c/Asmblockdeps.v | 1094 ++++++++------------------ mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 28 +- mppa_k1c/abstractbb/Parallelizability.v | 8 +- 3 files changed, 338 insertions(+), 792 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 402e3178..a676d7b2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -12,6 +12,7 @@ Require Import Coqlib. Require Import ImpDep. Require Import Axioms. Require Import Parallelizability. +Require Import Asmvliw Permutation. Open Scope impure. @@ -470,9 +471,6 @@ Import P. (** Compilation from Asmblock to L *) -Section SECT. -Variable Ge: genv. - Local Open Scope positive_scope. Definition pmem : R.t := 1. @@ -676,6 +674,17 @@ Proof. intros. congruence. Qed. +(** Parallelizability of a bblock (bundle) *) + +Module PChk := ParallelChecks L PosPseudoRegSet. + +Definition bblock_para_check (p: Asmvliw.bblock) : bool := + PChk.is_parallelizable (trans_block p). + +Section SECT_PAR. + +Import PChk. + Ltac Simplif := ((rewrite nextblock_inv by eauto with asmgen) || (rewrite nextblock_inv1 by eauto with asmgen) @@ -692,535 +701,394 @@ Ltac Simpl := repeat Simplif. Arguments Pos.add: simpl never. Arguments ppos: simpl never. -Theorem trans_state_match: forall S, match_states S (trans_state S). -Proof. - intros. destruct S as (rs & m). simpl. - split. reflexivity. - intro. destruct r; try reflexivity. - destruct g; reflexivity. -Qed. - -Lemma exec_app_some: - forall c c' s s' s'', - exec Ge c s = Some s' -> - exec Ge c' s' = Some s'' -> - exec Ge (c ++ c') s = Some s''. -Proof. - induction c. - - simpl. intros. congruence. - - intros. simpl in *. destruct (inst_run _ _ _ _); auto. eapply IHc; eauto. discriminate. -Qed. - -Lemma exec_app_none: - forall c c' s, - exec Ge c s = None -> - exec Ge (c ++ c') s = None. -Proof. - induction c. - - simpl. discriminate. - - intros. simpl. simpl in H. destruct (inst_run _ _ _ _); auto. -Qed. +Variable Ge: genv. -Lemma trans_arith_correct: - forall ge fn i rs m rs' s, - exec_arith_instr ge i rs = rs' -> - match_states (State rs m) s -> - exists s', - inst_run (Genv ge fn) (trans_arith i) s s = Some s' - /\ match_states (State rs' m) s'. +Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_arith_instr ge i rsr rsw = rsw' -> + exists sw', + inst_prun Ge (trans_arith i) sw sr sr = Some sw' + /\ match_states (State rsw' mw) sw'. Proof. - intros. unfold exec_arith_instr in H. unfold parexec_arith_instr in H. destruct i. + intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. + unfold parexec_arith_instr. destruct i. (* Ploadsymbol *) - - inv H; inv H0. eexists; split; try split. + - destruct i. eexists; split; [| split]. + * simpl. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. + * simpl. intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRR *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rs0). rewrite e; reflexivity. + - eexists; split; [| split]. + * simpl. rewrite (H0 rs). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRI32 *) - - inv H. inv H0. - eexists; split; try split. + - eexists; split; [|split]. + * simpl. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRI64 *) - - inv H. inv H0. - eexists; split; try split. + - eexists; split; [|split]. + * simpl. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRF32 *) - - inv H. inv H0. - eexists; split; try split. + - eexists; split; [|split]. + * simpl. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRF64 *) - - inv H. inv H0. - eexists; split; try split. + - eexists; split; [|split]. + * simpl. reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRRR *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rs1); rewrite e. pose (H1 rs2); rewrite e0. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRRI32 *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rs0); rewrite e. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithRRI64 *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rs0); rewrite e. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithARRR *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rd); rewrite e. pose (H1 rs1); rewrite e0. pose (H1 rs2); rewrite e1. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithARRI32 *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rd); rewrite e. pose (H1 rs0); rewrite e0. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. (* PArithARRI64 *) - - inv H; inv H0; - eexists; split; try split. - * simpl. pose (H1 rd); rewrite e. pose (H1 rs0); rewrite e0. reflexivity. + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. Qed. -Theorem forward_simu_basic_gen ge fn b rs m s: - match_states (State rs m) s -> - match_outcome (exec_basic_instr ge b rs m) (inst_run (Genv ge fn) (trans_basic b) s s). +Theorem forward_simu_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). Proof. - intros. destruct b; inversion H; simpl. + intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). + destruct bi; simpl. (* Arith *) - - eapply trans_arith_correct; eauto. destruct i; simpl; reflexivity. + - exploit trans_arith_par_correct. 5: eauto. all: eauto. (* Load *) - destruct i. - (* Load Offset *) - + destruct i; simpl; - unfold parexec_load_offset; rewrite (H1 ra); rewrite H0; - destruct (eval_offset _ _); simpl; auto; destruct (Mem.loadv _ _); simpl; auto; - eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - + destruct i; simpl; - unfold parexec_load_reg; rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold exec_load_deps_reg; - destruct (Mem.loadv _ _); simpl; auto; - eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + (* Load Offset *) + + destruct i; simpl load_chunk. all: + unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; + destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; 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; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Store *) - destruct i. - (* Store Offset *) - + destruct i; simpl; - rewrite (H1 rs0); rewrite (H1 ra); rewrite H0; unfold parexec_store_offset; destruct (eval_offset _ _); simpl; auto; - destruct (Mem.storev _ _ _ _); simpl; auto; - eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + (* Store Offset *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_offset; simpl; unfold exec_store_deps_offset; erewrite GENV, H, H0; rewrite (H0 ra); + destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. - + destruct i; simpl; - rewrite (H1 rs0); rewrite (H1 ra); rewrite (H1 rofs); rewrite H0; unfold parexec_store_reg; unfold exec_store_deps_reg; - destruct (Mem.storev _ _ _ _); simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + (* Store Reg *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_reg; simpl; unfold exec_store_deps_reg; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. (* Allocframe *) - - Simpl. rewrite (H1 SP). rewrite H0. destruct (Mem.alloc _ _ _) eqn:ALLOC; simpl; auto. destruct (Mem.store _ _ _ _) eqn:STORE; simpl; auto. - eexists; split; try split. - * Simpl. rewrite H0. rewrite ALLOC. rewrite STORE. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. - -(* Freeframe *) - - rewrite (H1 SP). rewrite H0. destruct (Mem.loadv _ _ _) eqn:LOAD; simpl; auto. destruct (rs GPR12) eqn:SPeq; simpl; auto. - destruct (Mem.free _ _ _ _) eqn:FREE; simpl; auto. Simpl. rewrite (H1 SP). eexists; split; try split. - * rewrite SPeq. rewrite LOAD. rewrite FREE. reflexivity. + - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. + * eexists; repeat split. + { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. + rewrite H, MEMAL. rewrite MEMS. reflexivity. } + { Simpl. } + { intros rr; destruct rr; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. } + * simpl; Simpl; erewrite !H0, H, MEMAL, MEMS; auto. + (* Freeframe *) + - erewrite !H0, H. + destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto. + destruct (rsr GPR12) eqn:SPeq; simpl; auto. + destruct (Mem.free _ _ _ _) eqn:MFREE; simpl; auto. + eexists; repeat split. + * simpl. Simpl. erewrite H0, SPeq, MLOAD, MFREE. reflexivity. * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g FP)]]; subst; Simpl. - + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. (* Pget *) - - destruct rs0; simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. - + - destruct rs eqn:rseq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. (* Pset *) - - destruct rd; simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - + - destruct rd eqn:rdeq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. (* Pnop *) - - eexists; split; try split. assumption. assumption. -Qed. - -Lemma forward_simu_basic ge fn b rs m rs' m' s: - exec_basic_instr ge b rs m = Next rs' m' -> - match_states (State rs m) s -> - exists s', - inst_run (Genv ge fn) (trans_basic b) s s = Some s' - /\ match_states (State rs' m') s'. -Proof. - intros. exploit forward_simu_basic_gen; eauto. intros. rewrite H in H1. inv H1. eexists. eassumption. + - eexists. repeat split; assumption. Qed. -Lemma forward_simu_basic_instr_stuck i ge fn rs m s: - Ge = Genv ge fn -> - exec_basic_instr ge i rs m = Stuck -> - match_states (State rs m) s -> - exec Ge [trans_basic i] s = None. -Proof. - intros. exploit forward_simu_basic_gen; eauto. intros. rewrite H0 in H2. inv H2. unfold exec. unfold run. rewrite H4. reflexivity. -Qed. -Lemma forward_simu_body: - forall bdy ge rs m rs' m' fn s, +Theorem forward_simu_par_body: + forall bdy ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> - exec_body ge bdy rs m = Next rs' m' -> - match_states (State rs m) s -> - exists s', - exec Ge (trans_body bdy) s = Some s' - /\ match_states (State rs' m') s'. + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + match_outcome (parexec_wio_body ge bdy rsr rsw mr mw) (prun_iw Ge (trans_body bdy) sw sr). Proof. - induction bdy. - - intros. inv H1. simpl in *. inv H0. eexists. repeat (split; auto). - - intros until s. intros GE EXEB MS. simpl in EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. - exploit forward_simu_basic; eauto. intros (s' & MRUN & MS'). subst Ge. - eapply IHbdy in MS'; eauto. destruct MS' as (s'' & EXECB & MS'). - eexists. split. - * simpl. rewrite MRUN. eassumption. - * eassumption. + 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. + - intros (s' & X1 & X2). rewrite X1; simpl; eauto. + - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_control_gen ge fn ex b rs m s: +Theorem forward_simu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> - match_states (State rs m) s -> - match_outcome (exec_control ge fn ex (nextblock b rs) m) (exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s). + 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. destruct ex; simpl; inv H0. - - destruct c; destruct i; simpl; rewrite (H2 PC); auto. - all: try (eexists; split; try split; Simpl; intros rr; destruct rr; unfold nextblock, incrPC; Simpl). + intros GENV MSR MSW; unfold parexec_exit. + simpl in *. inv MSR. inv MSW. + destruct ex. + - destruct c; destruct i; try discriminate; simpl. + all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold incrPC; Simpl). (* Pjumptable *) - + Simpl. rewrite (H2 r). destruct (rs r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. - unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold incrPC. Simpl. + destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. + unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - destruct (preg_eq GPR62 g). rewrite e. Simpl. - destruct (preg_eq GPR63 g). rewrite e. Simpl. Simpl. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. + destruct (preg_eq g GPR62). rewrite e. Simpl. + destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. (* Pj_l *) - + Simpl. unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. - unfold nextblock, incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. + unfold incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. (* Pcb *) - + Simpl. destruct (cmp_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold par_eval_branch; unfold eval_branch_deps. - ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b0. - +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b0. - +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. + ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. (* Pcbu *) - + Simpl. destruct (cmpu_for_btest _); simpl; auto. rewrite (H2 r). destruct o; simpl; auto. destruct i; unfold par_eval_branch; unfold eval_branch_deps. - ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b0. - +++ unfold par_goto_label; unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. unfold nextblock, incrPC; Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - +++ simpl. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. - - - simpl. rewrite (H2 PC). eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. -Qed. + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. + ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. -Lemma forward_simu_control ge fn ex b rs m rs2 m2 s: - Ge = Genv ge fn -> - exec_control ge fn ex (nextblock b rs) m = Next rs2 m2 -> - match_states (State rs m) s -> - exists s', - exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = Some s' - /\ match_states (State rs2 m2) s'. -Proof. - intros. exploit (forward_simu_control_gen); eauto. intros. - rewrite H0 in H2. inv H2. eexists. eapply H3. + - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. + intros rr; destruct rr; unfold incrPC; Simpl. Qed. -Lemma forward_simu_control_stuck: - forall ge fn rs m s ex b, +Theorem forward_simu_par_exit ex sz ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> - match_states (State rs m) s -> - exec Ge (trans_pcincr (size b) (trans_exit ex) :: nil) s = None -> - exec_control ge fn ex (nextblock b rs) m = Stuck. -Proof. - intros. exploit (forward_simu_control_gen); eauto. intros. - rewrite H1 in H2. destruct (exec_control _ _ _ _ _); auto. inv H2. inv H3. discriminate. -Qed. - -Theorem forward_simu: - forall rs1 m1 rs2 m2 s1' b ge fn, - Ge = Genv ge fn -> - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - match_states (State rs1 m1) s1' -> - exists s2', - exec Ge (trans_block b) s1' = Some s2' - /\ match_states (State rs2 m2) s2'. + 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). Proof. - intros until fn. intros GENV EXECB MS. unfold exec_bblock in EXECB. destruct (exec_body _ _ _) eqn:EXEB; try discriminate. - exploit forward_simu_body; eauto. intros (s' & EXETRANSB & MS'). - exploit forward_simu_control; eauto. intros (s'' & EXETRANSEX & MS''). - - eexists. split. - unfold trans_block. eapply exec_app_some. eassumption. eassumption. - eassumption. + intros; unfold parexec_exit. + exploit (forward_simu_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. -Lemma exec_bblock_stuck_nec: - forall ge fn b rs m, - exec_body ge (body b) rs m = Stuck - \/ (exists rs' m', exec_body ge (body b) rs m = Next rs' m' /\ exec_control ge fn (exit b) (nextblock b rs') m' = Stuck) - <-> exec_bblock ge fn b rs m = Stuck. -Proof. - intros. split. - + intros. destruct H. - - unfold exec_bblock. rewrite H. reflexivity. - - destruct H as (rs' & m' & EXEB & EXEC). unfold exec_bblock. rewrite EXEB. assumption. - + intros. unfold exec_bblock in H. destruct (exec_body _ _ _ _) eqn:EXEB. - - right. repeat eexists. assumption. - - left. reflexivity. -Qed. +Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). -Lemma exec_basic_instr_next_exec: - forall ge fn i rs m rs' m' s tc, +Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz: Ge = Genv ge fn -> - exec_basic_instr ge i rs m = Next rs' m' -> - match_states (State rs m) s -> - exists s', - exec Ge (trans_basic i :: tc) s = exec Ge tc s' - /\ match_states (State rs' m') s'. + 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). Proof. - intros. exploit forward_simu_basic; eauto. - intros (s' & MRUN & MS'). - simpl exec. exists s'. subst. rewrite MRUN. split; auto. + 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. + 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. + 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. -Lemma exec_body_next_exec: - forall c ge fn rs m rs' m' s tc, +Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz: Ge = Genv ge fn -> - exec_body ge c rs m = Next rs' m' -> - match_states (State rs m) s -> - exists s', - exec Ge (trans_body c ++ tc) s = exec Ge tc s' - /\ match_states (State rs' m') s'. + 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 + | 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). Proof. - induction c. - - intros. simpl in H0. inv H0. simpl. exists s. split; auto. - - intros. simpl in H0. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. - exploit exec_basic_instr_next_exec; eauto. intros (s' & EXEGEBASIC & MS'). - simpl trans_body. rewrite <- app_comm_cons. rewrite EXEGEBASIC. - eapply IHc; eauto. + 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. + - intros (s' & X1 & X2). + erewrite prun_iw_app_Some; eauto. + eapply forward_simu_par_body; eauto. + - intros; erewrite prun_iw_app_None; eauto. Qed. -Lemma exec_trans_pcincr_exec_instrun: - forall rs m s b k, - match_states (State rs m) s -> - exists s', - inst_run Ge ((# PC, Op (OIncremPC (size b)) (PReg(# PC) @ Enil)) :: k) s s = inst_run Ge k s' s - /\ match_states (State (nextblock b rs) m) s'. +Lemma trans_body_perserves_permutation bdy1 bdy2: + Permutation bdy1 bdy2 -> + Permutation (trans_body bdy1) (trans_body bdy2). Proof. - intros. inv H. eexists. split. simpl. pose (H1 PC); simpl in e; rewrite e. destruct Ge. simpl. eapply eq_refl. - simpl. split. - - Simpl. - - intros rr; destruct rr; Simpl. + induction 1; simpl; econstructor; eauto. Qed. -Lemma inst_run_trans_exit_noold: - forall ex s s' s'', - inst_run Ge (trans_exit ex) s s' = inst_run Ge (trans_exit ex) s s''. +Lemma trans_body_app bdy1: forall bdy2, + trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). Proof. - intros. destruct ex. - - destruct c; destruct i; reflexivity. - - reflexivity. + induction bdy1; simpl; congruence. Qed. -Lemma exec_trans_pcincr_exec: - forall rs m s b, - match_states (State rs m) s -> - exists s', - exec Ge (trans_pcincr (size b) (trans_exit (exit b)) :: nil) s = exec Ge [trans_exit (exit b)] s' - /\ match_states (State (nextblock b rs) m) s'. +Theorem trans_block_perserves_permutation bdy1 bdy2 b: + Permutation (bdy1 ++ bdy2) (body b) -> + Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). Proof. - intros. - exploit exec_trans_pcincr_exec_instrun; eauto. - intros (s' & MRUN & MS). - eexists. split. unfold exec. unfold trans_pcincr. unfold run. rewrite MRUN. - erewrite inst_run_trans_exit_noold; eauto. - assumption. + intro H; unfold trans_block, trans_block_aux. + eapply perm_trans. + - eapply Permutation_app_tail. + apply trans_body_perserves_permutation. + apply Permutation_sym; eapply H. + - rewrite trans_body_app. rewrite <-! app_assoc. + apply Permutation_app_head. + apply Permutation_app_comm. Qed. -Lemma exec_exit_none: - forall ge fn rs m s ex, - Ge = Genv ge fn -> - match_states (State rs m) s -> - exec Ge [trans_exit ex] s = None -> - exec_control ge fn ex rs m = Stuck. -Proof. - intros. inv H0. destruct ex as [ctl|]; try discriminate. - destruct ctl; destruct i; try reflexivity; try discriminate. -(* Pjumptable *) - - simpl in *. repeat (rewrite H3 in H1). - destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. - unfold goto_label_deps in H1. unfold par_goto_label. Simpl. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. -(* Pj_l *) - - simpl in *. pose (H3 PC); simpl in e; rewrite e in H1. clear e. - unfold goto_label_deps in H1. unfold par_goto_label. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. -(* Pcb *) - - simpl in *. destruct (cmp_for_btest bt). destruct i. - + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold par_eval_branch. - destruct (Val.cmp_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. - destruct (rs PC); auto. discriminate. - + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold par_eval_branch. - destruct (Val.cmpl_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. - destruct (rs PC); auto. discriminate. -(* Pcbu *) - - simpl in *. destruct (cmpu_for_btest bt). destruct i. - + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. - pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold par_eval_branch. - destruct (Val_cmpu_bool _ _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. - destruct (rs PC); auto. discriminate. - + pose (H3 PC); simpl in e; rewrite e in H1; clear e. - destruct o; auto. - pose (H3 r); simpl in e; rewrite e in H1; clear e. - unfold eval_branch_deps in H1; unfold par_eval_branch. - destruct (Val_cmplu_bool _ _); auto. destruct b; try discriminate. - unfold goto_label_deps in H1; unfold par_goto_label. destruct (label_pos _ _ _); auto. - destruct (rs PC); auto. discriminate. +Theorem forward_simu_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 -> + exists o2', + prun Ge (trans_block b) s1' o2' + /\ match_outcome o2 o2'. +Proof. + intros GENV MS PAREXEC. + 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. + rewrite <- WIO. clear WIO. + intros H; eexists; split. 2: eapply H. + unfold prun; eexists; split; eauto. + destruct (prun_iw _ _ _ _); simpl; eauto. Qed. -Theorem trans_block_reverse_stuck: - forall ge fn b rs m s, +(* sequential execution *) +Theorem forward_simu_basic ge fn bi rs m s: Ge = Genv ge fn -> - exec Ge (trans_block b) s = None -> match_states (State rs m) s -> - exec_bblock ge fn b rs m = Stuck. + match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s). Proof. - intros until s. intros Geq EXECBK MS. - apply exec_bblock_stuck_nec. - destruct (exec_body _ _ _ _) eqn:EXEB. - - right. repeat eexists. - exploit exec_body_next_exec; eauto. - intros (s' & EXECBK' & MS'). unfold trans_block in EXECBK. rewrite EXECBK' in EXECBK. clear EXECBK'. clear EXEB MS. - eapply forward_simu_control_stuck; eauto. - - left. reflexivity. + intros; unfold exec_basic_instr. rewrite inst_run_prun. + eapply forward_simu_par_wio_basic; eauto. Qed. -Lemma forward_simu_body_stuck: +Lemma forward_simu_body: forall bdy ge fn rs m s, Ge = Genv ge fn -> - exec_body ge bdy rs m = Stuck -> match_states (State rs m) s -> - exec Ge (trans_body bdy) s = None. + match_outcome (exec_body ge bdy rs m) (exec Ge (trans_body bdy) s). Proof. - induction bdy. - - simpl. discriminate. - - intros. simpl trans_body. simpl in H0. - destruct (exec_basic_instr _ _ _ _) eqn:EBI. - + exploit exec_basic_instr_next_exec; eauto. intros (s' & EXEGEB & MS'). rewrite EXEGEB. eapply IHbdy; eauto. - + cutrewrite (trans_basic a :: trans_body bdy = (trans_basic a :: nil) ++ trans_body bdy); try reflexivity. apply exec_app_none. - eapply forward_simu_basic_instr_stuck; eauto. + induction bdy as [|i bdy]; simpl; eauto. + intros. + exploit (forward_simu_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. - -Lemma forward_simu_exit_stuck: - forall ex ge fn rs m s, +Theorem forward_simu_exit ge fn b rs m s: Ge = Genv ge fn -> - exec_control ge fn ex rs m = Stuck -> match_states (State rs m) s -> - exec Ge [(trans_exit ex)] s = None. + 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. inv H1. destruct ex as [ctl|]; try discriminate. - destruct ctl; destruct i; try discriminate; try (simpl; reflexivity). - (* Pjumptable *) - - simpl in *. repeat (rewrite H3). destruct (rs r); try discriminate; auto. destruct (list_nth_z _ _); try discriminate; auto. - unfold goto_label_deps. unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. repeat (rewrite Pregmap.gso in H0; try discriminate). destruct (rs PC); auto. discriminate. -(* Pj_l *) - - simpl in *. pose (H3 PC); simpl in e; rewrite e. unfold goto_label_deps. unfold par_goto_label in H0. - destruct (label_pos _ _ _); auto. clear e. destruct (rs PC); auto. discriminate. -(* Pcb *) - - simpl in *. destruct (cmp_for_btest bt). destruct i. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmp_bool _ _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val.cmpl_bool _ _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. -(* Pcbu *) - - simpl in *. destruct (cmpu_for_btest bt). destruct i. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmpu_bool _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. - -- destruct o. - + unfold par_eval_branch in H0; unfold eval_branch_deps. - pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. destruct (Val_cmplu_bool _ _); auto. - destruct b; try discriminate. unfold goto_label_deps; unfold par_goto_label in H0. clear e0. - destruct (label_pos _ _ _); auto. destruct (rs PC); auto. discriminate. - + pose (H3 r); simpl in e; rewrite e. pose (H3 PC); simpl in e0; rewrite e0. reflexivity. + 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. Qed. - -Theorem forward_simu_stuck: - forall rs1 m1 s1' b ge fn, +Theorem forward_simu rs m b ge fn s: Ge = Genv ge fn -> - exec_bblock ge fn b rs1 m1 = Stuck -> - match_states (State rs1 m1) s1' -> - exec Ge (trans_block b) s1' = None. + 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. + 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. + subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl. + destruct (inst_run _ _ _); simpl; auto. + - intros X; erewrite run_app_None; eauto. +Qed. + + +Theorem trans_state_match: forall S, match_states S (trans_state S). Proof. - intros until fn. intros GENV EXECB MS. apply exec_bblock_stuck_nec in EXECB. destruct EXECB. - - unfold trans_block. apply exec_app_none. eapply forward_simu_body_stuck; eauto. - - destruct H as (rs' & m' & EXEB & EXEC). unfold trans_block. exploit exec_body_next_exec; eauto. - intros (s' & EXEGEBODY & MS'). rewrite EXEGEBODY. exploit exec_trans_pcincr_exec; eauto. - intros (s'' & EXEGEPC & MS''). rewrite EXEGEPC. eapply forward_simu_exit_stuck; eauto. + intros. destruct S as (rs & m). simpl. + split. reflexivity. + intro. destruct r; try reflexivity. + destruct g; reflexivity. Qed. @@ -1230,26 +1098,47 @@ Proof. intros. congruence. Qed. -Theorem state_equiv: - forall S1 S2 S', match_states S1 S' /\ match_states S2 S' -> S1 = S2. +Theorem state_equiv S1 S2 S': match_states S1 S' -> match_states S2 S' -> S1 = S2. Proof. - intros. inv H. unfold match_states in H0, H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. + unfold match_states; intros H0 H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. apply state_eq_decomp. - apply functional_extensionality. intros. assert (Val (rs1 x) = Val (rs2 x)) by congruence. congruence. - congruence. Qed. -Theorem forward_simu_alt: - forall rs1 m1 s1' b ge fn, - Ge = Genv ge fn -> - match_states (State rs1 m1) s1' -> - match_outcome (exec_bblock ge fn b rs1 m1) (exec Ge (trans_block b) s1'). +Lemma bblock_para_check_correct ge fn bb rs m rs' m': + Ge = Genv ge fn -> + exec_bblock ge fn bb rs m = Next rs' m' -> + bblock_para_check bb = true -> + det_parexec ge fn bb rs m rs' m'. Proof. - intros until fn. intros GENV MS. destruct (exec_bblock _ _ _ _ _) eqn:EXEB. - - eapply forward_simu; eauto. - - eapply forward_simu_stuck; eauto. + 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. + rewrite H0; simpl. + intros (s2' & EXEC & MS). + exploit forward_simu_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'. + - inv PRUN. inv H3. unfold exec in EXEC; unfold trans_state in H. + assert (x = s2') by congruence. subst. clear H. + assert (m0 = s2') by (apply functional_extensionality; auto). subst. clear H4. + destruct o; try discriminate. inv MO. inv H. assert (s2' = x) by congruence. subst. + exploit (state_equiv (State rs' m') (State rs0 m0)). + 2: eapply H4. eapply MS. intro H. inv H. reflexivity. + - unfold match_outcome in MO. destruct o. + + inv MO. inv H3. discriminate. + + clear MO. unfold exec in EXEC. + unfold trans_state in PRUN; rewrite EXEC in PRUN. discriminate. Qed. +End SECT_PAR. + + +Section SECT_BBLOCK_EQUIV. + +Variable Ge: genv. + Local Hint Resolve trans_state_match. Lemma bblock_equiv_reduce: @@ -1262,8 +1151,8 @@ Proof. intros rs m. generalize (H2 (trans_state (State rs m))); clear H2. intro H2. - exploit (forward_simu_alt rs m (trans_state (State rs m)) p1 ge fn); eauto. - exploit (forward_simu_alt rs m (trans_state (State rs m)) p2 ge fn); eauto. + 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. remember (exec_bblock ge fn p1 rs m) as exp1. destruct exp1. + (* Next *) @@ -1572,377 +1461,8 @@ Definition bblock_equivb: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bbloc Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. -End SECT. - -(** Parallelizability of a bblock *) - -Module PChk := ParallelChecks L PosPseudoRegSet. - -Definition bblock_para_check (p: Asmvliw.bblock) : bool := - PChk.is_parallelizable (trans_block p). - -Require Import Asmvliw Permutation. -Import PChk. - -Section SECT_PAR. - -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) - || (rewrite assign_diff by (auto; try discriminate; try (apply ppos_discr; try discriminate; congruence); try (apply ppos_pmem_discr); - try (apply not_eq_sym; apply ppos_discr; try discriminate; congruence); try (apply not_eq_sym; apply ppos_pmem_discr); auto)) - || (rewrite assign_eq) - ); auto with asmgen. +End SECT_BBLOCK_EQUIV. -Ltac Simpl := repeat Simplif. -Arguments Pos.add: simpl never. -Arguments ppos: simpl never. -Variable Ge: genv. -Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_arith_instr ge i rsr rsw = rsw' -> - exists sw', - inst_prun Ge (trans_arith i) sw sr sr = Some sw' - /\ match_states (State rsw' mw) sw'. -Proof. - intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. - unfold parexec_arith_instr. destruct i. -(* Ploadsymbol *) - - destruct i. eexists; split; [| split]. - * simpl. reflexivity. - * Simpl. - * simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRR *) - - eexists; split; [| split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRI32 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRI64 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRF32 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRF64 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRR *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRI32 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRI64 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRR *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRI32 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRI64 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -Qed. - -Theorem forward_simu_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). -Proof. - intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). - destruct bi; simpl. -(* Arith *) - - exploit trans_arith_par_correct. 5: eauto. all: eauto. -(* Load *) - - destruct i. - (* Load Offset *) - + destruct i; simpl load_chunk. all: - unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; - destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; - destruct (Mem.loadv _ _ _) eqn:MEML; 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; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - -(* Store *) - - destruct i. - (* Store Offset *) - + destruct i; simpl store_chunk. all: - unfold parexec_store_offset; simpl; unfold exec_store_deps_offset; erewrite GENV, H, H0; rewrite (H0 ra); - destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; - destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl. - - (* Store Reg *) - + destruct i; simpl store_chunk. all: - unfold parexec_store_reg; simpl; unfold exec_store_deps_reg; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); - destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl. - -(* Allocframe *) - - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. - * eexists; repeat split. - { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. - rewrite H, MEMAL. rewrite MEMS. reflexivity. } - { Simpl. } - { intros rr; destruct rr; Simpl. - destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. } - * simpl; Simpl; erewrite !H0, H, MEMAL, MEMS; auto. - (* Freeframe *) - - erewrite !H0, H. - destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto. - destruct (rsr GPR12) eqn:SPeq; simpl; auto. - destruct (Mem.free _ _ _ _) eqn:MFREE; simpl; auto. - eexists; repeat split. - * simpl. Simpl. erewrite H0, SPeq, MLOAD, MFREE. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. -(* Pget *) - - destruct rs eqn:rseq; simpl; auto. - eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* Pset *) - - destruct rd eqn:rdeq; simpl; auto. - eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. -(* Pnop *) - - eexists. repeat split; assumption. -Qed. - - -Theorem forward_simu_par_body: - forall bdy ge fn rsr mr sr rsw mw sw, - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (parexec_wio_body ge bdy rsr rsw mr mw) (prun_iw Ge (trans_body bdy) sw sr). -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. - - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - - intros X; rewrite X; simpl; auto. -Qed. - -Theorem forward_simu_par_control 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_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). -Proof. - intros GENV MSR MSW. - simpl in *. inv MSR. inv MSW. - destruct ex. - - destruct c; destruct i; try discriminate; simpl. - all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold incrPC; Simpl). - - (* Pjumptable *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold incrPC. Simpl. - destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. - unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. - destruct (preg_eq g GPR62). rewrite e. Simpl. - destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. - - (* Pj_l *) - + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. - unfold incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. - - (* Pcb *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. - ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - - (* Pcbu *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. - ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - - - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. - intros rr; destruct rr; unfold incrPC; Simpl. -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: - 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). -Proof. - intros H H0 H1. unfold parexec_wio_bblock_aux, trans_block_aux. - exploit (forward_simu_par_body bdy ge fn rsr mr sr rsw mw sw); eauto. - destruct (parexec_wio_body _ _ _ _ _ _); simpl. - - intros (s' & X1 & X2). - erewrite prun_iw_app_Some; eauto. - unfold parexec_exit. - exploit (forward_simu_par_control ex sz ge fn rsr rs mr m sr s'); eauto. - subst Ge; simpl. destruct H0 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: - 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 - | 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). -Proof. - intros H H0 H1. - 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. - - intros (s' & X1 & X2). - erewrite prun_iw_app_Some; eauto. - eapply forward_simu_par_body; eauto. - - intros X; erewrite prun_iw_app_None; eauto. -Qed. - -Lemma trans_body_perserves_permutation bdy1 bdy2: - Permutation bdy1 bdy2 -> - Permutation (trans_body bdy1) (trans_body bdy2). -Proof. - induction 1; simpl; econstructor; eauto. -Qed. - -Lemma trans_body_app bdy1: forall bdy2, - trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). -Proof. - induction bdy1; simpl; congruence. -Qed. - -Theorem trans_block_perserves_permutation bdy1 bdy2 b: - Permutation (bdy1 ++ bdy2) (body b) -> - Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). -Proof. - intro H; unfold trans_block, trans_block_aux. - eapply perm_trans. - - eapply Permutation_app_tail. - apply trans_body_perserves_permutation. - apply Permutation_sym; eapply H. - - rewrite trans_body_app. rewrite <-! app_assoc. - apply Permutation_app_head. - apply Permutation_app_comm. -Qed. - -Theorem forward_simu_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 -> - exists o2', - prun Ge (trans_block b) s1' o2' - /\ match_outcome o2 o2'. -Proof. - intros GENV MS PAREXEC. - 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. - rewrite <- WIO. clear WIO. - intros H; eexists; split. 2: eapply H. - unfold prun; eexists; split; eauto. - destruct (prun_iw _ _ _ _); simpl; eauto. -Qed. - - -Lemma bblock_para_check_correct ge fn bb rs m rs' m': - Ge = Genv ge fn -> - exec_bblock ge fn bb rs m = Next rs' m' -> - bblock_para_check bb = true -> - 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; eauto. eapply trans_state_match. - intros (s2' & EXEC & MS). - exploit forward_simu_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'. - - inv PRUN. inv H3. unfold exec in EXEC. assert (x = s2') by congruence. subst. clear H. - assert (m0 = s2') by (apply functional_extensionality; auto). subst. clear H4. - destruct o; try discriminate. inv MO. inv H. assert (s2' = x) by congruence. subst. - exploit state_equiv. split. eapply MS. eapply H4. intros. inv H. reflexivity. - - unfold match_outcome in MO. destruct o. - + inv MO. inv H3. discriminate. - + clear MO. unfold exec in EXEC. rewrite EXEC in PRUN. discriminate. -Qed. - -End SECT_PAR. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 3023ad8a..d1950209 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -211,7 +211,33 @@ Proof. intros; eapply res_eq_trans. eapply alt_bblock_equiv_refl; eauto. eauto. Qed. - + + +Lemma run_app p1: forall m1 p2, + run (p1++p2) m1 = + match run p1 m1 with + | Some m2 => run p2 m2 + | None => None + end. +Proof. + induction p1; simpl; try congruence. + intros; destruct (inst_run _ _ _); simpl; auto. +Qed. + +Lemma run_app_None p1 m1 p2: + run p1 m1 = None -> + run (p1++p2) m1 = None. +Proof. + intro H; rewrite run_app. rewrite H; auto. +Qed. + +Lemma run_app_Some p1 m1 m2 p2: + run p1 m1 = Some m2 -> + run (p1++p2) m1 = run p2 m2. +Proof. + intros H; rewrite run_app. rewrite H; auto. +Qed. + End SEQLANG. End MkSeqLanguage. diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index d1971e57..eae7b672 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -91,18 +91,18 @@ Proof. intros; destruct (inst_prun _ _ _); simpl; auto. Qed. -Lemma prun_iw_app_None p1: forall m1 old p2, +Lemma prun_iw_app_None p1 m1 old p2: prun_iw p1 m1 old = None -> prun_iw (p1++p2) m1 old = None. Proof. - intros m1 old p2 H; rewrite prun_iw_app. rewrite H; auto. + intros H; rewrite prun_iw_app. rewrite H; auto. Qed. -Lemma prun_iw_app_Some p1: forall m1 old m2 p2, +Lemma prun_iw_app_Some p1 m1 old m2 p2: prun_iw p1 m1 old = Some m2 -> prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. Proof. - intros m1 old m2 p2 H; rewrite prun_iw_app. rewrite H; auto. + intros H; rewrite prun_iw_app. rewrite H; auto. Qed. End PARALLEL. -- cgit From 1d7796d6d39eb9d7ff79ac3d1fee1e107ce204f4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 11 Apr 2019 14:38:20 +0200 Subject: more robust pattern-matching in *op_eq --- mppa_k1c/Asmblockdeps.v | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a676d7b2..4559dd62 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -346,10 +346,11 @@ Hint Resolve arith_op_eq_correct: wlp. Opaque arith_op_eq_correct. Definition load_op_eq (o1 o2: load_op): ?? bool := - match o1, o2 with - | OLoadRRO n1 ofs1, OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) - | OLoadRRR n1, OLoadRRR n2 => phys_eq n1 n2 - | _, _ => RET false + match o1 with + | OLoadRRO n1 ofs1 => + match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) | _ => RET false end + | OLoadRRR n1 => + match o2 with OLoadRRR n2 => phys_eq n1 n2 | _ => RET false end end. Lemma load_op_eq_correct o1 o2: @@ -364,10 +365,11 @@ Opaque load_op_eq_correct. Definition store_op_eq (o1 o2: store_op): ?? bool := - match o1, o2 with - | OStoreRRO n1 ofs1, OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) - | OStoreRRR n1, OStoreRRR n2 => phys_eq n1 n2 - | _, _ => RET false + match o1 with + | OStoreRRO n1 ofs1 => + match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) | _ => RET false end + | OStoreRRR n1 => + match o2 with OStoreRRR n2 => phys_eq n1 n2 | _ => RET false end end. Lemma store_op_eq_correct o1 o2: -- cgit From fa27e482f043116bb39ff4d410f12f0b09a18f3b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 15:32:05 +0200 Subject: adjust list of builtins according to documentation --- mppa_k1c/CBuiltins.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 9fe5c958..914d1aa8 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -29,14 +29,14 @@ let builtins = { "__builtin_k1_doze", (TVoid [], [], false); (* opcode not supported in assembly, not in documentation *) "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) - "__builtin_k1_invaldtlb", (TVoid [], [], false); - "__builtin_k1_invalitlb", (TVoid [], [], false); - "__builtin_k1_probetlb", (TVoid [], [], false); - "__builtin_k1_readtlb", (TVoid [], [], false); "__builtin_k1_sleep", (TVoid [], [], false); (* DONE *) "__builtin_k1_stop", (TVoid [], [], false); (* DONE *) - "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); + "__builtin_k1_syncgroup", (TVoid [], [TInt(IULongLong, [])], false); + "__builtin_k1_tlbread", (TVoid [], [], false); "__builtin_k1_tlbwrite", (TVoid [], [], false); + "__builtin_k1_tlbprobe", (TVoid [], [], false); + "__builtin_k1_tlbdinval", (TVoid [], [], false); + "__builtin_k1_tlbiinval", (TVoid [], [], false); "__builtin_k1_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); (* DONE *) "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) -- cgit From b42e3f8b36c5b3d8511f3428fce4190bbec73d19 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 11 Apr 2019 15:34:05 +0200 Subject: update from Impure Library --- mppa_k1c/abstractbb/Impure/ImpLoops.v | 42 ++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v index 9e11195e..dc8b2627 100644 --- a/mppa_k1c/abstractbb/Impure/ImpLoops.v +++ b/mppa_k1c/abstractbb/Impure/ImpLoops.v @@ -11,38 +11,38 @@ Local Open Scope impure. Axiom loop: forall {A B}, A * (A -> ?? (A+B)) -> ?? B. Extract Constant loop => "ImpLoopOracles.loop". -(** A while loop *) -Record while_loop_invariant {S} (cond: S -> bool) (body: S -> ?? S) (s0: S) (I: S -> Prop): Prop := - { while_init: I s0; - while_preserv s: I s -> cond s = true -> WHEN (body s) ~> s' THEN I s' - }. -Arguments while_init [S cond body s0 I]. -Arguments while_preserv [S cond body s0 I]. +Section While_Loop. -Program Definition while {S} cond body s0 (I: S -> Prop | while_loop_invariant cond body s0 I): ?? {s | I s /\ cond s = false} - := loop (A:={s | I s}) +(** 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} + := loop (A:={s | I s0 -> I s}) (s0, fun s => match (cond s) with | true => DO s' <~ mk_annot (body s) ;; - RET (inl (A:={s | I s }) s') + RET (inl (A:={s | I s0 -> I s }) s') | false => - RET (inr (B:={s | I s /\ cond s = false}) s) + RET (inr (B:={s | I s0 -> I s /\ cond s = false}) s) end). -Obligation 1. - destruct H; auto. -Qed. Obligation 2. - eapply (while_preserv H1); eauto. + unfold wli, wlp in * |-; eauto. Qed. Extraction Inline while. -(** A loop until None (useful to demonstrate a UNSAT property) *) +End While_Loop. -Program Definition loop_until_None {S} (I: S -> Prop) (body: S -> ?? (option S)) - (H:forall s, I s -> WHEN (body s) ~> s' THEN match s' with Some s1 => I s1 | None => False end) (s0:S): ?? ~(I s0) + +Section Loop_Until_None. +(** useful to demonstrate a UNSAT property *) + +(** Local Definition of "loop-until-None-invariant" *) +Let luni {S} (body: S -> ?? (option S)) (I: S -> Prop) := forall s, I s -> WHEN (body s) ~> s' THEN match s' with Some s1 => I s1 | None => False end. + +Program Definition loop_until_None {S} body (I: S -> Prop | luni body I) s0: ?? ~(I s0) := loop (A:={s | I s0 -> I s}) (s0, fun s => @@ -52,13 +52,15 @@ Program Definition loop_until_None {S} (I: S -> Prop) (body: S -> ?? (option S)) | None => RET (inr (B:=~(I s0)) _) end). Obligation 2. - refine (H s _ _ H1). auto. + refine (H2 s _ _ H0). auto. Qed. Obligation 3. - intros X; refine (H s _ _ H0). auto. + intros X; refine (H1 s _ _ H). auto. Qed. Extraction Inline loop_until_None. +End Loop_Until_None. + (*********************************************) (* A generic fixpoint from an equality test *) -- cgit From 17f22082bfd1b7d68c1f3776ac494a4b1fa8cbfc Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 11 Apr 2019 17:09:14 +0200 Subject: trans_code_decompose proof --- mppa_k1c/Machblockgenproof.v | 87 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 86 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index e729a907..47f74d90 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -366,6 +366,45 @@ Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c . +Lemma Mlabel_is_not_basic i: + forall bi, trans_inst i = MB_basic bi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma Mlabel_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma MBbasic_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall bi, trans_inst i <> MB_basic bi. +Proof. +intros. +unfold trans_inst in H. +unfold trans_inst. +destruct i; congruence. +Qed. + +Lemma add_to_new_block_is_label i: + header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. +Proof. + intros. + unfold add_to_new_bblock in H. + destruct (trans_inst i) eqn : H1. + + exists lbl. + unfold trans_inst in H1. + destruct i; congruence. + + unfold add_basic in H; simpl in H; congruence. + + unfold cfi_bblock in H; simpl in H; congruence. +Qed. + + Lemma trans_code_decompose c: forall b bl, is_trans_code c (b::bl) -> exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. @@ -386,7 +425,53 @@ Proof. intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). repeat econstructor; eauto. + (* basic at end block *) -Admitted. (* A FINIR *) + inversion H1; subst. + lapply (Mlabel_is_not_basic i bi); auto. + intro H2. + - inversion H0; subst. + assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } + repeat econstructor; congruence. + - exists (i::c), c, c. + repeat econstructor; eauto. + * lapply (Mlabel_is_not_basic i bi); auto. + * inversion H0; subst; repeat econstructor. + inversion H1. + subst. + exploit (add_to_new_block_is_label i0); eauto. + intro H8; destruct H8. + rewrite H2. unfold trans_inst. congruence. + unfold trans_inst. congruence. + exploit H3. + unfold add_basic; eauto. + intro F; destruct F. + * inversion H0; subst; econstructor. + exploit (add_to_new_block_is_label i0); eauto. + intros H8. destruct H8. + rewrite H2. + unfold trans_inst; congruence. + unfold trans_inst; congruence. + rewrite H7. congruence. + + unfold trans_inst in Heqti. congruence. + + (* basic at mid block *) + inversion H1. symmetry in H4. subst. + exploit IHc; eauto. + intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). + exists (i::c0), c1, c2. + repeat econstructor; eauto. + rewrite H2 in H3. + inversion H3; econstructor; apply (Mlabel_is_not_basic i bi); eauto. + + (* cfi at end block *) + inversion H1; subst. inversion H0; subst. + repeat econstructor; eauto. + apply (Mlabel_is_not_cfi i cfi); eauto. + apply (MBbasic_is_not_cfi i cfi); eauto. + exists (i::c), (i::c), c. + repeat econstructor; eauto. + apply (Mlabel_is_not_cfi i cfi); eauto. + apply (MBbasic_is_not_cfi i cfi); eauto. + + unfold trans_inst in Heqti. congruence. +Qed. + Lemma step_simu_header st f sp rs m s c h c' t: is_header h c c' -> -- cgit From 4571fc5fade196c02d68c4feb5e5a1b862d37041 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 11 Apr 2019 22:29:14 +0200 Subject: more builtins --- mppa_k1c/Asm.v | 5 +++++ mppa_k1c/Asmexpand.ml | 14 ++++++++++++++ mppa_k1c/CBuiltins.ml | 6 +++--- mppa_k1c/TargetPrinter.ml | 11 ++++++++++- 4 files changed, 32 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index a9a88d75..f679335c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -80,6 +80,9 @@ Inductive instruction : Type := | 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 @@ -94,6 +97,8 @@ Inductive instruction : Type := | 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 *) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 872a29f5..ba771bcb 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -381,6 +381,16 @@ let expand_builtin_inline name args res = let open Asmvliw in else emit (Pwfxm(n, src))) | "__builtin_k1_ldu", [BA(IR addr)], BR(IR res) -> emit (Pldu(res, addr)) + | "__builtin_k1_lbzu", [BA(IR addr)], BR(IR res) -> + emit (Plbzu(res, addr)) + | "__builtin_k1_lhzu", [BA(IR addr)], BR(IR res) -> + emit (Plhzu(res, addr)) + | "__builtin_k1_lwzu", [BA(IR addr)], BR(IR res) -> + emit (Plwzu(res, addr)) + | "__builtin_k1_alclrd", [BA(IR addr)], BR(IR res) -> + emit (Palclrd(res, addr)) + | "__builtin_k1_alclrw", [BA(IR addr)], BR(IR res) -> + emit (Palclrw(res, addr)) | "__builtin_k1_await", [], _ -> emit Pawait | "__builtin_k1_sleep", [], _ -> @@ -413,6 +423,10 @@ let expand_builtin_inline name args res = let open Asmvliw in (if res <> incr_res then (emit (Pmv(res, incr_res)); emit Psemi)); emit (Pafaddw(addr, res)) + | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> + emit (Palclrd(res, addr)) + | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> + emit (Palclrw(res, addr)) (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 914d1aa8..dfa11ba4 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -42,9 +42,9 @@ let builtins = { "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) (* LSU Instructions *) - (* No ACWS - __int128 *) - "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); - "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); + (* afaddd and afaddw done using headers and assembly *) + "__builtin_k1_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4599f2a1..ca158cb9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -288,6 +288,12 @@ module Target (*: TARGET*) = fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst | Pldu(dst, addr) -> fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr + | Plbzu(dst, addr) -> + fprintf oc " lbz.u %a = 0[%a]\n" ireg dst ireg addr + | Plhzu(dst, addr) -> + fprintf oc " lhz.u %a = 0[%a]\n" ireg dst ireg addr + | Plwzu(dst, addr) -> + fprintf oc " lwz.u %a = 0[%a]\n" ireg dst ireg addr | Pawait -> fprintf oc " await\n" | Psleep -> @@ -316,7 +322,10 @@ module Target (*: TARGET*) = fprintf oc " 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 - + | Palclrd(res, addr) -> + fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr + | Palclrw(res, addr) -> + fprintf oc " alclrw %a = 0[%a]\n" ireg res ireg addr | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in (* jumptables := (lbl, tbl) :: !jumptables; *) -- cgit From 525720d136acb20dca47f31655c1940cc341c69e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 04:57:21 +0200 Subject: fix wrongly removed builtins --- mppa_k1c/CBuiltins.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index dfa11ba4..2f80c90f 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -42,7 +42,9 @@ let builtins = { "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) (* LSU Instructions *) - (* afaddd and afaddw done using headers and assembly *) + (* 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_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) -- cgit From 7e921e5ac243b453e6ec856abd5af2eed810226d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 11:06:32 +0200 Subject: more simplifications --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 4 ++++ 2 files changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 71e0eff3..c5a86ac1 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -353,6 +353,8 @@ Nondetfunction notint (e: expr) := | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) + | Eop Onot (e1:::Enil) => e1 + | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil | _ => Eop Onot (e:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 4af5ccfa..65038038 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -679,6 +679,10 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. + - rewrite <- H0. + exists v1. + split; auto. + - TrivialExists. - TrivialExists. Qed. -- cgit From 4b78052471c339c1e7dbbabe9ac20835fe963b9c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 11:26:50 +0200 Subject: some more simplifications --- mppa_k1c/SelectOp.vp | 7 ++++++- mppa_k1c/SelectOpproof.v | 21 +++++++++++---------- 2 files changed, 17 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index c5a86ac1..72f5616c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -327,7 +327,12 @@ Nondetfunction or (e1: expr) (e2: expr) := end. Nondetfunction xorimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 else + if Int.eq n1 Int.zero + then e2 + else + if Int.eq n1 Int.mone + then Eop Onot (e2:::Enil) + else match e2 with | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil | Eop (Oxorimm n2) (t2:::Enil) => diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 65038038..023f2a3c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -648,16 +648,17 @@ Proof. intros; red; intros until x. unfold xorimm. predSpec Int.eq Int.eq_spec n Int.zero. - intros. exists x; split. auto. - destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. - - intros. destruct (xorimm_match a); intros; InvEval. - - TrivialExists. simpl. rewrite Int.xor_commut; auto. - - subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. - predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. - + exists v1; split; auto. destruct v1; simpl; auto. rewrite H0, Int.xor_zero; auto. - + TrivialExists. - - TrivialExists. + - intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + - predSpec Int.eq Int.eq_spec n Int.mone. + -- subst n. intros. rewrite <- Val.not_xor. TrivialExists. + -- intros. destruct (xorimm_match a); intros; InvEval. + + TrivialExists. simpl. rewrite Int.xor_commut; auto. + + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. + predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. + * exists v1; split; auto. destruct v1; simpl; auto. rewrite H1, Int.xor_zero; auto. + * TrivialExists. + + TrivialExists. Qed. Theorem eval_xor: binary_constructor_sound xor Val.xor. -- cgit From 6a267e0bce732e68ab5e5b6c971ba5e0fe226719 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 11:46:13 +0200 Subject: some more simplifications --- mppa_k1c/SelectOp.vp | 6 ++++++ mppa_k1c/SelectOpproof.v | 22 +++++++++++++++++++--- 2 files changed, 25 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 72f5616c..d6dfdce1 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -358,6 +358,12 @@ Nondetfunction notint (e: expr) := | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) + | Eop Onand (e1:::e2:::Enil) => Eop Oand (e1:::e2:::Enil) + | Eop (Onandimm n) (e1:::Enil) => Eop (Oandimm n) (e1:::Enil) + | Eop Onor (e1:::e2:::Enil) => Eop Oor (e1:::e2:::Enil) + | Eop (Onorimm n) (e1:::Enil) => Eop (Oorimm n) (e1:::Enil) + | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) + | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) | Eop Onot (e1:::Enil) => e1 | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil | _ => Eop Onot (e:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 023f2a3c..c836fb86 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -680,9 +680,25 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - - rewrite <- H0. - exists v1. - split; auto. + - subst x. exists (Val.and v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.and v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.or v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.or v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.xor v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.xor v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists v1; split; trivial. - TrivialExists. - TrivialExists. Qed. -- cgit From 56249c0fa5aa96767ce3fd9be76b8a9e7bef0231 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 12:30:49 +0200 Subject: some more simplifications --- mppa_k1c/SelectOp.vp | 1 + mppa_k1c/SelectOpproof.v | 6 ++++++ 2 files changed, 7 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d6dfdce1..019de37d 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -364,6 +364,7 @@ Nondetfunction notint (e: expr) := | Eop (Onorimm n) (e1:::Enil) => Eop (Oorimm n) (e1:::Enil) | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) + | Eop Oandn (e1:::e2:::Enil) => Eop Oorn (e2:::e1:::Enil) | Eop Onot (e1:::Enil) => e1 | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil | _ => Eop Onot (e:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index c836fb86..76cfdafe 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -698,6 +698,12 @@ Proof. - subst x. exists (Val.xor v1 (Vint n)); split; trivial. econstructor. constructor. eassumption. constructor. simpl. reflexivity. + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_and_or_not. + rewrite Int.not_involutive. + apply Int.or_commut. - subst x. exists v1; split; trivial. - TrivialExists. - TrivialExists. -- cgit From af3bf7d993ebccd93577bc0986a6ab45729fdc1d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 12:38:48 +0200 Subject: some more simplification --- mppa_k1c/SelectOp.vp | 1 + mppa_k1c/SelectOpproof.v | 6 ++++++ 2 files changed, 7 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 019de37d..da0049fe 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -365,6 +365,7 @@ Nondetfunction notint (e: expr) := | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) | Eop Oandn (e1:::e2:::Enil) => Eop Oorn (e2:::e1:::Enil) + | Eop Oorn (e1:::e2:::Enil) => Eop Oandn (e2:::e1:::Enil) | Eop Onot (e1:::Enil) => e1 | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil | _ => Eop Onot (e:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 76cfdafe..49980c51 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -704,6 +704,12 @@ Proof. rewrite Int.not_and_or_not. rewrite Int.not_involutive. apply Int.or_commut. + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_or_and_not. + rewrite Int.not_involutive. + apply Int.and_commut. - subst x. exists v1; split; trivial. - TrivialExists. - TrivialExists. -- cgit From 43e2036b6f10efdb7e63613067da16fa7fa4b421 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 12:56:12 +0200 Subject: some more simplification --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 14 ++++++++++++++ 2 files changed, 16 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index da0049fe..d5e3ee4a 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -365,7 +365,9 @@ Nondetfunction notint (e: expr) := | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) | Eop Oandn (e1:::e2:::Enil) => Eop Oorn (e2:::e1:::Enil) + | Eop (Oandnimm n) (e1:::Enil) => Eop (Oorimm (Int.not n)) (e1:::Enil) | Eop Oorn (e1:::e2:::Enil) => Eop Oandn (e2:::e1:::Enil) + | Eop (Oornimm n) (e1:::Enil) => Eop (Oandimm (Int.not n)) (e1:::Enil) | Eop Onot (e1:::Enil) => e1 | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil | _ => Eop Onot (e:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 49980c51..fe2ff816 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -698,18 +698,32 @@ Proof. - subst x. exists (Val.xor v1 (Vint n)); split; trivial. econstructor. constructor. eassumption. constructor. simpl. reflexivity. + (* andn *) - subst x. TrivialExists. simpl. destruct v0; destruct v1; simpl; trivial. f_equal. f_equal. rewrite Int.not_and_or_not. rewrite Int.not_involutive. apply Int.or_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_and_or_not. + rewrite Int.not_involutive. + reflexivity. + (* orn *) - subst x. TrivialExists. simpl. destruct v0; destruct v1; simpl; trivial. f_equal. f_equal. rewrite Int.not_or_and_not. rewrite Int.not_involutive. apply Int.and_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_or_and_not. + rewrite Int.not_involutive. + reflexivity. - subst x. exists v1; split; trivial. - TrivialExists. - TrivialExists. -- cgit From 64d7dab2720d63e1b40ae893d76895a23c11e2d1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 13:08:58 +0200 Subject: more simplifications --- mppa_k1c/SelectLong.vp | 3 +++ mppa_k1c/SelectLongproof.v | 18 ++++++++++-------- 2 files changed, 13 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index f7cb3c82..6389bca2 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -302,6 +302,9 @@ Nondetfunction orl (e1: expr) (e2: expr) := Nondetfunction xorlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone + then Eop Onotl (e2:::Enil) + else match e2 with | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) | Eop (Oxorlimm n2) (t2:::Enil) => diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3fab35b3..d4893eb8 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -534,14 +534,16 @@ Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Va Proof. unfold xorlimm; intros; red; intros. predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. - destruct (xorlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. -- rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). - predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. -+ rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. -+ TrivialExists. -- TrivialExists. + - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. + - predSpec Int64.eq Int64.eq_spec n Int64.mone. + -- subst n. intros. rewrite <- Val.notl_xorl. TrivialExists. + -- destruct (xorlimm_match a); InvEval; subst. + + econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. + + rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). + predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. + * rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. + * TrivialExists. + + TrivialExists. Qed. Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. -- cgit From 819e0e55f945923adc6e8cfccb2e7a9b44a814ac Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 13:27:38 +0200 Subject: some simplifications (long) --- mppa_k1c/SelectLong.vp | 12 ++++++++++++ mppa_k1c/SelectLongproof.v | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 6389bca2..ed2006b0 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -331,6 +331,18 @@ Nondetfunction notl (e: expr) := | Eop (Oorlimm n) (e1:::Enil) => Eop (Onorlimm n) (e1:::Enil) | Eop Oxorl (e1:::e2:::Enil) => Eop Onxorl (e1:::e2:::Enil) | Eop (Oxorlimm n) (e1:::Enil) => Eop (Onxorlimm n) (e1:::Enil) + | Eop Onandl (e1:::e2:::Enil) => Eop Oandl (e1:::e2:::Enil) + | Eop (Onandlimm n) (e1:::Enil) => Eop (Oandlimm n) (e1:::Enil) + | Eop Onorl (e1:::e2:::Enil) => Eop Oorl (e1:::e2:::Enil) + | Eop (Onorlimm n) (e1:::Enil) => Eop (Oorlimm n) (e1:::Enil) + | Eop Onxorl (e1:::e2:::Enil) => Eop Oxorl (e1:::e2:::Enil) + | Eop (Onxorlimm n) (e1:::Enil) => Eop (Oxorlimm n) (e1:::Enil) + | Eop Oandnl (e1:::e2:::Enil) => Eop Oornl (e2:::e1:::Enil) + | Eop (Oandnlimm n) (e1:::Enil) => Eop (Oorlimm (Int64.not n)) (e1:::Enil) + | Eop Oornl (e1:::e2:::Enil) => Eop Oandnl (e2:::e1:::Enil) + | Eop (Oornlimm n) (e1:::Enil) => Eop (Oandlimm (Int64.not n)) (e1:::Enil) + | Eop Onotl (e1:::Enil) => e1 + | Eop (Olongconst k) Enil => Eop (Olongconst (Int64.not k)) Enil | _ => Eop Onotl (e:::Enil) end. (* old: if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. *) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index d4893eb8..0700ac4d 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -566,6 +566,52 @@ Proof. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. - TrivialExists; simpl; congruence. + - subst x. exists (Val.andl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.andl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.orl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.orl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.xorl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.xorl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + (* andn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_and_or_not. + rewrite Int64.not_involutive. + apply Int64.or_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_and_or_not. + rewrite Int64.not_involutive. + reflexivity. + (* orn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_or_and_not. + rewrite Int64.not_involutive. + apply Int64.and_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_or_and_not. + rewrite Int64.not_involutive. + reflexivity. + - subst x. exists v1; split; trivial. + - TrivialExists. - TrivialExists. Qed. -- cgit From 5cc18b7860630f822ada1e56ae73c6d96b372361 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 12 Apr 2019 13:45:14 +0200 Subject: some more simplifications --- mppa_k1c/SelectLong.vp | 1 + mppa_k1c/SelectLongproof.v | 1 + 2 files changed, 2 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index ed2006b0..811a8ab1 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -276,6 +276,7 @@ Nondetfunction orlimm (n1: int64) (e2: expr) := match e2 with | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | Eop Onotl (t2:::Enil) => Eop (Oornlimm n1) (t2:::Enil) | _ => Eop (Oorlimm n1) (e2:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 0700ac4d..3fa35331 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -439,6 +439,7 @@ Proof. destruct (orlimm_match a); InvEval; subst. - econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. - TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. +- InvEval. TrivialExists. - TrivialExists. Qed. -- cgit From 67be67deebe911c6f202338178e53787f17dd76d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 13 Apr 2019 09:19:44 +0200 Subject: dirty fix for issue #112 That should not be the final say on this. --- mppa_k1c/TargetPrinter.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ca158cb9..5aedd557 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -393,10 +393,14 @@ module Target (*: TARGET*) = fprintf oc " floatuw.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfloatwrnsz(rd, rs) -> fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatudrnsz(rd, rs) | Pfloatudrnsz_i32(rd, rs) -> + | Pfloatudrnsz(rd, rs) -> fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatdrnsz(rd, rs) | Pfloatdrnsz_i32(rd, rs) -> - fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatudrnsz_i32(rd, rs) -> + fprintf oc " zxwd %a = %a\n # FIXME\n ;;\n floatud.rn.s %a = %a, 0\n" ireg rd ireg rs ireg rd ireg rd + | Pfloatdrnsz(rd, rs) -> + fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatdrnsz_i32(rd, rs) -> + fprintf oc " sxwd %a = %a\n # FIXME\n ;;\n floatd.rn.s %a = %a, 0\n" ireg rd ireg rs ireg rd ireg rd | Pfixedwrzz(rd, rs) -> fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs | Pfixeduwrzz(rd, rs) -> -- cgit From 6ba62341b1a453e1e7fafa827133f4f899235813 Mon Sep 17 00:00:00 2001 From: tvdd Date: Thu, 18 Apr 2019 15:24:01 +0200 Subject: step_simu_header proof --- mppa_k1c/Machblockgenproof.v | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 47f74d90..d7ff5e12 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -391,6 +391,10 @@ unfold trans_inst. destruct i; congruence. Qed. + +Local Hint Resolve Mlabel_is_not_cfi. +Local Hint Resolve MBbasic_is_not_cfi. + Lemma add_to_new_block_is_label i: header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. Proof. @@ -461,14 +465,8 @@ Proof. rewrite H2 in H3. inversion H3; econstructor; apply (Mlabel_is_not_basic i bi); eauto. + (* cfi at end block *) - inversion H1; subst. inversion H0; subst. + inversion H1; subst; repeat econstructor; eauto. - apply (Mlabel_is_not_cfi i cfi); eauto. - apply (MBbasic_is_not_cfi i cfi); eauto. - exists (i::c), (i::c), c. - repeat econstructor; eauto. - apply (Mlabel_is_not_cfi i cfi); eauto. - apply (MBbasic_is_not_cfi i cfi); eauto. + unfold trans_inst in Heqti. congruence. Qed. @@ -478,8 +476,11 @@ Lemma step_simu_header st f sp rs m s c h c' t: starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. Proof. - induction 1; simpl. (* A FINIR *) -Admitted. + induction 1; simpl; intros hs. + - inversion hs. split; reflexivity. + - inversion hs. split; reflexivity. + - inversion hs. inversion H1. subst. eauto. +Qed. (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? induction c as [ | i c]; simpl; intros h c' t H. - inversion_clear H. simpl; intros H; inversion H; auto. -- cgit From ec3d9703f2d8c76f6290d70a4620b1998e4c78cf Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Fri, 19 Apr 2019 19:08:33 +0200 Subject: petite simplif de preuve --- mppa_k1c/Machblockgenproof.v | 88 +++++++++++++------------------------------- 1 file changed, 26 insertions(+), 62 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index d7ff5e12..91dc58e8 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -408,6 +408,7 @@ Proof. + unfold cfi_bblock in H; simpl in H; congruence. Qed. +Local Hint Resolve Mlabel_is_not_basic. Lemma trans_code_decompose c: forall b bl, is_trans_code c (b::bl) -> @@ -418,7 +419,7 @@ Proof. intros b bl H; remember (trans_inst i) as ti. destruct ti as [lbl|bi|cfi]; inversion H as [|d0 d1 d2 H0 H1| |]; subst; - try (rewrite <- Heqti in * |- *); simpl; + try (rewrite <- Heqti in * |- *); simpl in * |- *; try congruence. + (* label at end block *) inversion H1; subst. inversion H0; subst. @@ -430,44 +431,29 @@ Proof. repeat econstructor; eauto. + (* basic at end block *) inversion H1; subst. - lapply (Mlabel_is_not_basic i bi); auto. - intro H2. + lapply (Mlabel_is_not_basic i bi); auto. + intro H2. - inversion H0; subst. assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } repeat econstructor; congruence. - exists (i::c), c, c. - repeat econstructor; eauto. - * lapply (Mlabel_is_not_basic i bi); auto. - * inversion H0; subst; repeat econstructor. - inversion H1. - subst. - exploit (add_to_new_block_is_label i0); eauto. - intro H8; destruct H8. - rewrite H2. unfold trans_inst. congruence. - unfold trans_inst. congruence. - exploit H3. - unfold add_basic; eauto. - intro F; destruct F. - * inversion H0; subst; econstructor. - exploit (add_to_new_block_is_label i0); eauto. - intros H8. destruct H8. - rewrite H2. - unfold trans_inst; congruence. - unfold trans_inst; congruence. - rewrite H7. congruence. - + unfold trans_inst in Heqti. congruence. + repeat econstructor; eauto; inversion H0; subst; repeat econstructor; simpl; try congruence. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + * exploit H3; eauto. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + (* basic at mid block *) - inversion H1. symmetry in H4. subst. + inversion H1; subst. exploit IHc; eauto. intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). exists (i::c0), c1, c2. repeat econstructor; eauto. rewrite H2 in H3. - inversion H3; econstructor; apply (Mlabel_is_not_basic i bi); eauto. + inversion H3; econstructor; eauto. + (* cfi at end block *) inversion H1; subst; repeat econstructor; eauto. - + unfold trans_inst in Heqti. congruence. Qed. @@ -476,21 +462,9 @@ Lemma step_simu_header st f sp rs m s c h c' t: starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. Proof. - induction 1; simpl; intros hs. - - inversion hs. split; reflexivity. - - inversion hs. split; reflexivity. - - inversion hs. inversion H1. subst. eauto. -Qed. -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - induction c as [ | i c]; simpl; intros h c' t H. - - inversion_clear H. simpl; intros H; inversion H; auto. - - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). - remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0]. - injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. - inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. - exploit IHc; eauto. + induction 1; simpl; intros hs; try (inversion hs; tauto). + inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. Qed. -*) Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): trans_inst i = MB_basic bi -> @@ -546,34 +520,22 @@ Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_M Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same. -Axiom TODO: False. (* a éliminer *) Lemma match_states_concat_trans_code st f sp c rs m h: match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). Proof. - intros; remember (trans_code _) as bl. - rewrite <- is_trans_code_inv in * |-. - constructor 1; simpl. - + intros (t0 & s1' & H0) t s'. - inversion Heqbl as [| | |]; subst; simpl; (* inversion vs induction ?? *) - elim TODO. (* A FAIRE *) - + intros H r; constructor 1; intro X; inversion X. -Qed. -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - constructor 1; simpl. + intros; constructor 1; simpl. + intros (t0 & s1' & H0) t s'. - rewrite! trans_code_equation. - destruct c as [| i c]. { inversion H0. } - remember (to_bblock (i :: c)) as bic. destruct bic as [b c0]. - simpl. - constructor 1; intros H; inversion H; subst; simpl in * |- *; - eapply exec_bblock; eauto. - - inversion H11; subst; eauto. - inversion H2; subst; eauto. - - inversion H11; subst; simpl; eauto. - inversion H2; subst; simpl; eauto. + remember (trans_code _) as bl. + destruct bl as [|bh bl]. + { rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; inversion H0; congruence. } + clear H0. + simpl; constructor 1; + intros X; inversion X as [d1 d2 d3 d4 d5 d6 d7 rs' m' d10 d11 X1 X2| | | ]; subst; simpl in * |- *; + eapply exec_bblock; eauto; simpl; + inversion X2 as [cfi d1 d2 d3 H1|]; subst; eauto; + inversion H1; subst; eauto. + intros H r; constructor 1; intro X; inversion X. Qed. -*) (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Lemma step_simu_cfi_step: @@ -703,6 +665,8 @@ Proof. eapply exec_return. Qed. +Axiom TODO: False. (* A ELIMINER *) + Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. -- cgit From aa3ac1afb0b05a2d80f697c2179b59f8c73c83fb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 24 Apr 2019 12:04:33 +0200 Subject: make_prologue à part MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 9 ++++++--- mppa_k1c/Asmblockgenproof.v | 6 +++--- 2 files changed, 9 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index bf466c4e..b00e4e89 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1060,12 +1060,15 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: end . +Definition make_prologue (f: Machblock.function) lb := + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b + Pget GPRA RA ::b + storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb). + Definition transl_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code) true; OK (mkfunction f.(Machblock.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b - Pget GPRA RA ::b - storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb)). + (make_prologue f lb)). Definition transf_function (f: Machblock.function) : res Asmvliw.function := do tf <- transl_function f; diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e3be258a..c6c88681 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -234,7 +234,7 @@ Lemma transl_find_label: end. Proof. intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. eapply transl_blocks_label; eauto. Qed. @@ -1686,11 +1686,11 @@ Proof. - eexact W'. - eexact W. } exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor. + simpl fn_blocks. unfold make_prologue in g. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. 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. unfold tfbody. simpl bblock_single_inst. omega. + simpl fn_blocks. unfold make_prologue in g. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor. econstructor; eauto. rewrite X; econstructor; eauto. -- cgit From 59089e5d11428dd224b3239bc7f5db602df9b177 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 24 Apr 2019 22:20:13 +0200 Subject: begin bitfields --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmvliw.v | 5 ++++- mppa_k1c/PostpassSchedulingOracle.ml | 1 + mppa_k1c/TargetPrinter.ml | 2 ++ 5 files changed, 11 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f679335c..2c3eef1f 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -129,6 +129,8 @@ Inductive instruction : Type := | 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 : int) (start : int) (**r extract bitfields unsigned *) | Pfabsd (rd rs: ireg) (**r float absolute double *) | Pfabsw (rd rs: ireg) (**r float absolute word *) | Pfnegd (rd rs: ireg) (**r float negate double *) @@ -280,6 +282,7 @@ Definition basic_to_instruction (b: basic) := | 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.Pfabsd rd rs => Pfabsd rd rs | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4559dd62..b9db7760 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1213,6 +1213,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Pcvtl2w => "Pcvtl2w" | Psxwd => "Psxwd" | Pzxwd => "Pzxwd" + | Pextfz _ _ => "Pextfz" | Pfabsd => "Pfabsd" | Pfabsw => "Pfabsw" | Pfnegd => "Pfnegd" diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 7177d5fe..a347b6fc 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -306,7 +306,9 @@ Inductive arith_name_rr : Type := | Pcvtl2w (**r Convert Long to Word *) | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) - +(* | Pextfs (stop : int) (start : int) (**r extract bit field, signed *) *) + | Pextfz (stop : int) (start : int) (**r extract bit field, unsigned *) + | Pfabsd (**r float absolute double *) | Pfabsw (**r float absolute word *) | Pfnegd (**r float negate double *) @@ -878,6 +880,7 @@ Definition arith_eval_rr n v := | Pcvtl2w => Val.loword v | Psxwd => Val.longofint v | Pzxwd => Val.longofintu v + | Pextfz stop start => Val.extfz stop start v | Pfnegd => Val.negf v | Pfnegw => Val.negfs v | Pfabsd => Val.absf v diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9a26425a..8f6484d6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -34,6 +34,7 @@ let arith_rr_str = function | Pnegl -> "Pnegl" | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" + | Pextfz(_,_) -> "Pextfz" | Pfabsw -> "Pfabsw" | Pfabsd -> "Pfabsd" | Pfnegw -> "Pfnegw" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5aedd557..dc207dc8 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -377,6 +377,8 @@ module Target (*: TARGET*) = fprintf oc " sxwd %a = %a\n" ireg rd ireg rs | Pzxwd(rd, rs) -> fprintf oc " zxwd %a = %a\n" ireg rd ireg rs + | Pextfz(rd, rs, stop, start) -> + fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) | Pfabsd(rd, rs) -> fprintf oc " fabsd %a = %a\n" ireg rd ireg rs | Pfabsw(rd, rs) -> -- cgit From 581d576e96463da6be672db1a85678a2a15f93a6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 07:17:06 +0200 Subject: some progress on bitfields --- mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 16 +++++++++++++++- mppa_k1c/SelectOp.vp | 8 ++++++++ mppa_k1c/SelectOpproof.v | 9 +++++++++ 4 files changed, 33 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index ba051c90..150c59e9 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -118,6 +118,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) + | Oextfz _ _ => op1 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 14758bee..8180c43f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -197,7 +197,8 @@ Inductive operation : Type := | 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] *) + | Oselectfs (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) + | Oextfz (stop : int) (start : int). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -498,6 +499,7 @@ Definition eval_operation | (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 (Val.extfz stop start v0) | _, _ => None end. @@ -691,6 +693,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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) + | Oextfz _ _ => (Tint :: nil, Tint) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -963,6 +966,11 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + destruct Archi.ptr64; simpl; trivial. destruct (_ && _); simpl; trivial. destruct (Val.cmp_different_blocks _); simpl; trivial. + (* extfz *) + - unfold Val.extfz. + destruct (_ && _ && _). + + destruct v0; simpl; trivial. + + constructor. Qed. End SOUNDNESS. @@ -1572,6 +1580,12 @@ Proof. reflexivity. assumption. * rewrite Hcond'. constructor. + + (* extfz *) + - unfold Val.extfz. + destruct (_ && _ && _). + + inv H4; trivial. + + trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d5e3ee4a..8f953425 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -202,6 +202,14 @@ Nondetfunction shrimm (e1: expr) (n: int) := if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) + | Eop (Oshlimm n1) (t1:::Enil) => + let stop := Int.sub Int.iwordsize (Int.add n1 Int.one) in + let start := Int.sub (Int.add (Int.add n stop) Int.one) Int.iwordsize in + if (Int.cmp Cle start stop) + && (Int.cmp Cge start Int.zero) + && (Int.cmp Clt stop Int.iwordsize) + then Eop (Oextfz stop start) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) | _ => Eop (Oshrimm n) (e1:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index fe2ff816..65ed212b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -334,6 +334,15 @@ Proof. rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. + - subst x. + destruct (_ && _ && _) eqn:BOUNDS. + + exists (Val.extfz (Int.sub Int.iwordsize (Int.add n1 Int.one)) + (Int.sub + (Int.add + (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) + Int.one) Int.iwordsize) v1). + split. + ++ constructor. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. -- cgit From 9c29503c6dbfee3c29c70b4ec8fed64b8ec2376a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 08:41:17 +0200 Subject: some more progress --- mppa_k1c/SelectOpproof.v | 18 +++++++++++++++++- mppa_k1c/ValueAOp.v | 23 ++++++++++++++++++++++- 2 files changed, 39 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 65ed212b..2c38ffae 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -342,7 +342,23 @@ Proof. (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) Int.one) Int.iwordsize) v1). split. - ++ constructor. + ++ EvalOp. + ++ unfold Val.extfz. + * simpl. rewrite BOUNDS. + destruct v1; simpl; trivial. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + replace (Int.sub Int.iwordsize + (Int.add (Int.sub Int.iwordsize (Int.add n1 Int.one)) Int.one)) with n1. + replace (Int.sub Int.iwordsize + (Int.sub + (Int.add (Int.sub Int.iwordsize (Int.add n1 Int.one)) Int.one) + (Int.sub + (Int.add + (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) + Int.one) Int.iwordsize))) with n. + constructor. + ** - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f17bd765..64002cef 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -74,6 +74,20 @@ Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : ava | _ => Vtop end. + +Definition eval_static_extfz (stop : int) (start : int) (v : aval) := + if (Int.cmp Cle start stop) + && (Int.cmp Cge start Int.zero) + && (Int.cmp Clt stop Int.iwordsize) + then + let stop' := Int.add stop Int.one in + match v with + | I w => + I (Int.shr (Int.shl w (Int.sub Int.iwordsize stop')) (Int.sub Int.iwordsize (Int.sub stop' start))) + | _ => Vtop + end + else Vtop. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -201,7 +215,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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 + | (Oselectfs cond), v0::v1::vselect::nil => eval_static_selectfs cond v0 v1 vselect + | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0 | _, _ => Vbot end. @@ -327,6 +342,12 @@ Proof. constructor. + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. constructor. + + (* extfz *) + - unfold Val.extfz, eval_static_extfz. + destruct (_ && _ && _). + + inv H1; constructor. + + constructor. Qed. End SOUNDNESS. -- cgit From b66d6034fb09e6129ca24dd458fbef49e4cb98d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 09:42:02 +0200 Subject: some progress --- mppa_k1c/SelectOpproof.v | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 2c38ffae..954ffba2 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -358,7 +358,11 @@ Proof. (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) Int.one) Int.iwordsize))) with n. constructor. - ** + ** repeat (try rewrite Int.add_signed; try rewrite Int.sub_signed; try rewrite Int.signed_repr). + rewrite <- (Int.repr_signed n) at 1. + f_equal. + omega. + - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. -- cgit From bb185aa85ddf32feed61d7888c1b199fffdd821f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 10:32:38 +0200 Subject: IT COMPILES --- mppa_k1c/Asm.v | 2 +- mppa_k1c/Asmvliw.v | 2 +- mppa_k1c/Op.v | 4 ++-- mppa_k1c/SelectOp.vp | 10 ++++----- mppa_k1c/SelectOpproof.v | 53 +++++++++++++++++++++++++----------------------- mppa_k1c/ValueAOp.v | 12 +++++------ 6 files changed, 43 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 2c3eef1f..290691f4 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -130,7 +130,7 @@ Inductive instruction : Type := | 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 : int) (start : int) (**r extract bitfields unsigned *) + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) | Pfabsd (rd rs: ireg) (**r float absolute double *) | Pfabsw (rd rs: ireg) (**r float absolute word *) | Pfnegd (rd rs: ireg) (**r float negate double *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index a347b6fc..b39ebd0e 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -307,7 +307,7 @@ Inductive arith_name_rr : Type := | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) (* | Pextfs (stop : int) (start : int) (**r extract bit field, signed *) *) - | Pextfz (stop : int) (start : int) (**r extract bit field, unsigned *) + | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) | Pfabsd (**r float absolute double *) | Pfabsw (**r float absolute word *) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 8180c43f..8293af1e 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -198,7 +198,7 @@ Inductive operation : Type := | 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 : int) (start : int). + | Oextfz (stop : Z) (start : Z). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -233,7 +233,7 @@ 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; intros. + 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. decide equality. Defined. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 8f953425..3e36a51c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -203,11 +203,11 @@ Nondetfunction shrimm (e1: expr) (n: int) := then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) | Eop (Oshlimm n1) (t1:::Enil) => - let stop := Int.sub Int.iwordsize (Int.add n1 Int.one) in - let start := Int.sub (Int.add (Int.add n stop) Int.one) Int.iwordsize in - if (Int.cmp Cle start stop) - && (Int.cmp Cge start Int.zero) - && (Int.cmp Clt stop Int.iwordsize) + let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) then Eop (Oextfz stop start) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) | _ => diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 954ffba2..d072bb7b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -321,7 +321,7 @@ Proof. predSpec Int.eq Int.eq_spec n Int.zero. intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. - destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (Int.ltu n Int.iwordsize) eqn:LT. destruct (shrimm_match a); intros; InvEval. - exists (Vint (Int.shr n1 n)); split. EvalOp. simpl. rewrite LT; auto. @@ -335,34 +335,37 @@ Proof. subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. - subst x. + simpl negb. + cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfz (Int.sub Int.iwordsize (Int.add n1 Int.one)) - (Int.sub - (Int.add - (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) - Int.one) Int.iwordsize) v1). + + exists (Val.extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize) v1). split. ++ EvalOp. ++ unfold Val.extfz. - * simpl. rewrite BOUNDS. - destruct v1; simpl; trivial. - destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. - destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. - replace (Int.sub Int.iwordsize - (Int.add (Int.sub Int.iwordsize (Int.add n1 Int.one)) Int.one)) with n1. - replace (Int.sub Int.iwordsize - (Int.sub - (Int.add (Int.sub Int.iwordsize (Int.add n1 Int.one)) Int.one) - (Int.sub - (Int.add - (Int.add n (Int.sub Int.iwordsize (Int.add n1 Int.one))) - Int.one) Int.iwordsize))) with n. - constructor. - ** repeat (try rewrite Int.add_signed; try rewrite Int.sub_signed; try rewrite Int.signed_repr). - rewrite <- (Int.repr_signed n) at 1. - f_equal. - omega. - + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int.zwordsize + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1). + replace (Z.sub Int.zwordsize + (Z.sub + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize))) with (Int.unsigned n). + * rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + * omega. + * omega. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 64002cef..e498d237 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -75,15 +75,15 @@ Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : ava end. -Definition eval_static_extfz (stop : int) (start : int) (v : aval) := - if (Int.cmp Cle start stop) - && (Int.cmp Cge start Int.zero) - && (Int.cmp Clt stop Int.iwordsize) +Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) then - let stop' := Int.add stop Int.one in + let stop' := Z.add stop Z.one in match v with | I w => - I (Int.shr (Int.shl w (Int.sub Int.iwordsize stop')) (Int.sub Int.iwordsize (Int.sub stop' start))) + I (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) | _ => Vtop end else Vtop. -- cgit From 5809fa295f23952a2d8b043f6da69d61da3568de Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 11:17:19 +0200 Subject: progress --- mppa_k1c/Asm.v | 3 +++ mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmvliw.v | 2 ++ mppa_k1c/NeedOp.v | 2 +- mppa_k1c/Op.v | 17 ++++++++++++++-- mppa_k1c/PostpassSchedulingOracle.ml | 1 + mppa_k1c/SelectOp.vp | 10 +++++++++- mppa_k1c/SelectOpproof.v | 38 +++++++++++++++++++++++++++++++++--- mppa_k1c/TargetPrinter.ml | 2 ++ mppa_k1c/ValueAOp.v | 22 ++++++++++++++++++++- 10 files changed, 90 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 290691f4..1e1f6e36 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -131,6 +131,8 @@ Inductive instruction : Type := | 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 *) + | Pfabsd (rd rs: ireg) (**r float absolute double *) | Pfabsw (rd rs: ireg) (**r float absolute word *) | Pfnegd (rd rs: ireg) (**r float negate double *) @@ -283,6 +285,7 @@ Definition basic_to_instruction (b: basic) := | 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.Pfabsd rd rs => Pfabsd rd rs | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b9db7760..b3a72517 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1214,6 +1214,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Psxwd => "Psxwd" | Pzxwd => "Pzxwd" | Pextfz _ _ => "Pextfz" + | Pextfs _ _ => "Pextfs" | Pfabsd => "Pfabsd" | Pfabsw => "Pfabsw" | Pfnegd => "Pfnegd" diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index b39ebd0e..13ff5422 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -308,6 +308,7 @@ Inductive arith_name_rr : Type := | Pzxwd (**r Zero Extend Word to Double Word *) (* | Pextfs (stop : int) (start : int) (**r extract bit field, signed *) *) | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) + | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) | Pfabsd (**r float absolute double *) | Pfabsw (**r float absolute word *) @@ -881,6 +882,7 @@ Definition arith_eval_rr n v := | Psxwd => Val.longofint v | Pzxwd => Val.longofintu v | Pextfz stop start => Val.extfz stop start v + | Pextfs stop start => Val.extfs stop start v | Pfnegd => Val.negf v | Pfnegw => Val.negfs v | Pfabsd => Val.absf v diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 150c59e9..3a27df6a 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -118,7 +118,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) - | Oextfz _ _ => op1 (default nv) + | Oextfz _ _ | Oextfs _ _ => op1 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 8293af1e..f6433f90 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -198,7 +198,8 @@ Inductive operation : Type := | 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). + | Oextfz (stop : Z) (start : Z) + | Oextfs (stop : Z) (start : Z). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -500,6 +501,7 @@ Definition eval_operation | (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 (Val.extfz stop start v0) + | (Oextfs stop start), v0::nil => Some (Val.extfs stop start v0) | _, _ => None end. @@ -693,7 +695,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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) - | Oextfz _ _ => (Tint :: nil, Tint) + | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -971,6 +973,11 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. + (* extfs *) + - unfold Val.extfs. + destruct (_ && _ && _). + + destruct v0; simpl; trivial. + + constructor. Qed. End SOUNDNESS. @@ -1586,6 +1593,12 @@ Proof. destruct (_ && _ && _). + inv H4; trivial. + trivial. + + (* extfs *) + - unfold Val.extfs. + destruct (_ && _ && _). + + inv H4; trivial. + + trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 8f6484d6..78a29fbb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -35,6 +35,7 @@ let arith_rr_str = function | Psxwd -> "Psxwd" | Pzxwd -> "Pzxwd" | Pextfz(_,_) -> "Pextfz" + | Pextfs(_,_) -> "Pextfs" | Pfabsw -> "Pfabsw" | Pfabsd -> "Pfabsd" | Pfnegw -> "Pfnegw" diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3e36a51c..6bb5ee56 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -186,6 +186,14 @@ Nondetfunction shruimm (e1: expr) (n: int) := if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) + | Eop (Oshlimm n1) (t1:::Enil) => + let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) + then Eop (Oextfz stop start) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) | _ => Eop (Oshruimm n) (e1:::Enil) end. @@ -208,7 +216,7 @@ Nondetfunction shrimm (e1: expr) (n: int) := if (Z.leb start stop) && (Z.geb start Z.zero) && (Z.ltb stop Int.zwordsize) - then Eop (Oextfz stop start) (t1:::Enil) + then Eop (Oextfs stop start) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) | _ => Eop (Oshrimm n) (e1:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index d072bb7b..8bc8c96b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -295,7 +295,7 @@ Proof. predSpec Int.eq Int.eq_spec n Int.zero. intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. - destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (Int.ltu n Int.iwordsize) eqn:LT. destruct (shruimm_match a); intros; InvEval. - exists (Vint (Int.shru n1 n)); split. EvalOp. simpl. rewrite LT; auto. @@ -307,6 +307,38 @@ Proof. rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. simpl. auto. + - subst x. + simpl negb. + cbn iota. + destruct (_ && _ && _) eqn:BOUNDS. + + exists (Val.extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold Val.extfz. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int.zwordsize + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1). + replace (Z.sub Int.zwordsize + (Z.sub + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize))) with (Int.unsigned n). + * rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + * omega. + * omega. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. @@ -338,14 +370,14 @@ Proof. simpl negb. cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + + exists (Val.extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) Z.one) Int.zwordsize) v1). split. ++ EvalOp. - ++ unfold Val.extfz. + ++ unfold Val.extfs. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int.zwordsize diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index dc207dc8..8826e6a2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -379,6 +379,8 @@ module Target (*: TARGET*) = fprintf oc " zxwd %a = %a\n" ireg rd ireg rs | Pextfz(rd, rs, stop, start) -> fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) + | Pextfs(rd, rs, stop, start) -> + fprintf oc " extfs %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) | Pfabsd(rd, rs) -> fprintf oc " fabsd %a = %a\n" ireg rd ireg rs | Pfabsw(rd, rs) -> diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index e498d237..23514d21 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -75,7 +75,7 @@ Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : ava end. -Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := +Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := if (Z.leb start stop) && (Z.geb start Z.zero) && (Z.ltb stop Int.zwordsize) @@ -88,6 +88,19 @@ Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := end else Vtop. +Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | I w => + I (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -217,6 +230,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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 | _, _ => Vbot end. @@ -348,6 +362,12 @@ Proof. destruct (_ && _ && _). + inv H1; constructor. + constructor. + + (* extfs *) + - unfold Val.extfs, eval_static_extfs. + destruct (_ && _ && _). + + inv H1; constructor. + + constructor. Qed. End SOUNDNESS. -- cgit From 2f549eaf7f6bc7e97d8f8a830d18808c2ae66186 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 11:36:28 +0200 Subject: read from bit fields --- mppa_k1c/Asmblockgen.v | 14 ++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++----- 2 files changed, 21 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index b00e4e89..6af18178 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -772,6 +772,20 @@ Definition transl_op OK (Pcmoveu bt r0 rS r1 ::i k) end) + | Oextfz stop start, a1 :: nil => + assertion ((Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize)); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfz stop start rd rs ::i k) + + | Oextfs stop start, a1 :: nil => + assertion ((Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize)); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfs stop start rd rs ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 78a29fbb..87f34ee6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -426,7 +426,7 @@ type real_instruction = | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd | Maddw | Maddd | Cmoved - | Make | Nop | Sxwd | Zxwd + | Make | Nop | Extfz | Extfs (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd @@ -476,8 +476,10 @@ let ab_inst_to_real = function | "Pmaddl" -> Maddd | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop - | "Psxwd" -> Sxwd - | "Pzxwd" -> Zxwd + | "Psxwd" -> Extfs + | "Pzxwd" -> Extfz + | "Pextfz" -> Extfz + | "Pextfs" -> Extfs | "Pfnarrowdw" -> Fnarrowdw | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz @@ -572,7 +574,7 @@ let rec_to_usage r = | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) - | Sxwd | Zxwd -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) + | Extfz | Extfs -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> (match encoding with None | Some U6 | Some S10 -> lsu_data @@ -595,7 +597,7 @@ let real_inst_to_latency = function | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make - | Sxwd | Zxwd | Fcompw | Fcompd | Cmoved + | Extfs | Extfz | Fcompw | Fcompd | Cmoved -> 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 *) -- cgit From 6d1223d053f1ff10792d5ed5d00d3830ff61e9d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 11:54:18 +0200 Subject: simplify proof slightly --- mppa_k1c/SelectOpproof.v | 36 ++++++++++++++++-------------------- 1 file changed, 16 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 8bc8c96b..4df87bea 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -322,22 +322,20 @@ Proof. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int.zwordsize - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1). + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. replace (Z.sub Int.zwordsize (Z.sub (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize))) with (Int.unsigned n). - * rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - simpl. - destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. - simpl. - destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. - * omega. - * omega. + Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. @@ -381,22 +379,20 @@ Proof. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int.zwordsize - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1). + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. replace (Z.sub Int.zwordsize (Z.sub (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize))) with (Int.unsigned n). - * rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - simpl. - destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. - simpl. - destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. - * omega. - * omega. + Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - TrivialExists. - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. -- cgit From ff1e531a3f2a58b6fbdc4a5a29f2520d5367c01c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 16:24:10 +0200 Subject: start of extfzl/extfsl --- mppa_k1c/Asm.v | 5 +++++ mppa_k1c/Asmblockdeps.v | 2 ++ mppa_k1c/Asmvliw.v | 4 ++++ mppa_k1c/PostpassSchedulingOracle.ml | 8 ++++---- mppa_k1c/TargetPrinter.ml | 4 ++-- 5 files changed, 17 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1e1f6e36..ec67d703 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -133,6 +133,9 @@ Inductive instruction : Type := | 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 *) + | Pfabsd (rd rs: ireg) (**r float absolute double *) | Pfabsw (rd rs: ireg) (**r float absolute word *) | Pfnegd (rd rs: ireg) (**r float negate double *) @@ -286,6 +289,8 @@ Definition basic_to_instruction (b: basic) := | 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b3a72517..a1a11701 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1215,6 +1215,8 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Pzxwd => "Pzxwd" | Pextfz _ _ => "Pextfz" | Pextfs _ _ => "Pextfs" + | Pextfzl _ _ => "Pextfzl" + | Pextfsl _ _ => "Pextfsl" | Pfabsd => "Pfabsd" | Pfabsw => "Pfabsw" | Pfnegd => "Pfnegd" diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 13ff5422..3c308960 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -309,6 +309,8 @@ Inductive arith_name_rr : Type := (* | Pextfs (stop : int) (start : int) (**r extract bit field, signed *) *) | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) + | Pextfzl (stop : Z) (start : Z) (**r extract bit field, unsigned *) + | Pextfsl (stop : Z) (start : Z) (**r extract bit field, signed *) | Pfabsd (**r float absolute double *) | Pfabsw (**r float absolute word *) @@ -883,6 +885,8 @@ Definition arith_eval_rr n v := | Pzxwd => Val.longofintu v | Pextfz stop start => Val.extfz stop start v | Pextfs stop start => Val.extfs stop start v + | Pextfzl stop start => Val.extfzl stop start v + | Pextfsl stop start => Val.extfsl stop start v | Pfnegd => Val.negf v | Pfnegw => Val.negfs v | Pfabsd => Val.absf v diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 87f34ee6..b9344116 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -36,6 +36,8 @@ let arith_rr_str = function | Pzxwd -> "Pzxwd" | Pextfz(_,_) -> "Pextfz" | Pextfs(_,_) -> "Pextfs" + | Pextfzl(_,_) -> "Pextfzl" + | Pextfsl(_,_) -> "Pextfsl" | Pfabsw -> "Pfabsw" | Pfabsd -> "Pfabsd" | Pfnegw -> "Pfnegw" @@ -476,10 +478,8 @@ let ab_inst_to_real = function | "Pmaddl" -> Maddd | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop - | "Psxwd" -> Extfs - | "Pzxwd" -> Extfz - | "Pextfz" -> Extfz - | "Pextfs" -> Extfs + | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz + | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs | "Pfnarrowdw" -> Fnarrowdw | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8826e6a2..f986db39 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -377,9 +377,9 @@ module Target (*: TARGET*) = fprintf oc " sxwd %a = %a\n" ireg rd ireg rs | Pzxwd(rd, rs) -> fprintf oc " zxwd %a = %a\n" ireg rd ireg rs - | Pextfz(rd, rs, stop, start) -> + | Pextfz(rd, rs, stop, start) | Pextfzl(rd, rs, stop, start) -> fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) - | Pextfs(rd, rs, stop, start) -> + | Pextfs(rd, rs, stop, start) | Pextfsl(rd, rs, stop, start) -> fprintf oc " extfs %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) | Pfabsd(rd, rs) -> fprintf oc " fabsd %a = %a\n" ireg rd ireg rs -- cgit From beb1cf4f6b56ee739e3a763de93663a875224402 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 25 Apr 2019 17:45:44 +0200 Subject: added code for extfzl/extfsl (not very useful since bitfields are limited to 32 bits) --- mppa_k1c/NeedOp.v | 2 +- mppa_k1c/Op.v | 29 ++++++++++++++++++++- mppa_k1c/SelectLong.vp | 16 ++++++++++++ mppa_k1c/SelectLongproof.v | 64 ++++++++++++++++++++++++++++++++++++++++++++-- mppa_k1c/ValueAOp.v | 40 +++++++++++++++++++++++++++++ 5 files changed, 147 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 3a27df6a..53c9c117 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -118,7 +118,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) - | Oextfz _ _ | Oextfs _ _ => op1 (default nv) + | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index f6433f90..99625f5c 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -199,7 +199,9 @@ Inductive operation : Type := | 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). + | Oextfs (stop : Z) (start : Z) + | Oextfzl (stop : Z) (start : Z) + | Oextfsl (stop : Z) (start : Z). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -502,6 +504,8 @@ Definition eval_operation | (Oselectfs cond), v0::v1::vselect::nil => Some (eval_selectfs cond v0 v1 vselect m) | (Oextfz stop start), v0::nil => Some (Val.extfz stop start v0) | (Oextfs stop start), v0::nil => Some (Val.extfs stop start v0) + | (Oextfzl stop start), v0::nil => Some (Val.extfzl stop start v0) + | (Oextfsl stop start), v0::nil => Some (Val.extfsl stop start v0) | _, _ => None end. @@ -696,6 +700,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oselectf cond => (Tfloat :: Tfloat :: (arg_type_of_condition0 cond) :: nil, Tfloat) | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle) | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) + | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -978,6 +983,16 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. + (* extfzl *) + - unfold Val.extfzl. + destruct (_ && _ && _). + + destruct v0; simpl; trivial. + + constructor. + (* extfsl *) + - unfold Val.extfsl. + destruct (_ && _ && _). + + destruct v0; simpl; trivial. + + constructor. Qed. End SOUNDNESS. @@ -1599,6 +1614,18 @@ Proof. destruct (_ && _ && _). + inv H4; trivial. + trivial. + + (* extfzl *) + - unfold Val.extfzl. + destruct (_ && _ && _). + + inv H4; trivial. + + trivial. + + (* extfsl *) + - unfold Val.extfsl. + destruct (_ && _ && _). + + inv H4; trivial. + + trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 811a8ab1..90901e04 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -155,6 +155,14 @@ Nondetfunction shrluimm (e1: expr) (n: int) := if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil) + | Eop (Oshllimm n1) (t1:::Enil) => + let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then Eop (Oextfzl stop start) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) | _ => Eop (Oshrluimm n) (e1:::Enil) end. @@ -172,6 +180,14 @@ Nondetfunction shrlimm (e1: expr) (n: int) := if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil) + | Eop (Oshllimm n1) (t1:::Enil) => + let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then Eop (Oextfsl stop start) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) | _ => Eop (Oshrlimm n) (e1:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3fa35331..451bded7 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -238,7 +238,7 @@ Proof. exists x; split; auto. subst n; destruct x; simpl; auto. destruct (Int.ltu Int.zero Int64.iwordsize'); auto. change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + destruct (Int.ltu n Int64.iwordsize') eqn:LT. assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. destruct (shrluimm_match a); InvEval. @@ -248,6 +248,36 @@ Proof. destruct v1; simpl; auto. rewrite LT'. destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. +- subst x. + simpl negb. + cbn iota. + destruct (_ && _ && _) eqn:BOUNDS. + + exists (Val.extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold Val.extfzl. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int64.zwordsize + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int64.zwordsize + (Z.sub + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. + simpl. + destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. + destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + constructor. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - apply DEFAULT. - TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. @@ -260,7 +290,7 @@ Proof. exists x; split; auto. subst n; destruct x; simpl; auto. destruct (Int.ltu Int.zero Int64.iwordsize'); auto. change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + destruct (Int.ltu n Int64.iwordsize') eqn:LT. assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. destruct (shrlimm_match a); InvEval. @@ -270,6 +300,36 @@ Proof. destruct v1; simpl; auto. rewrite LT'. destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. +- subst x. + simpl negb. + cbn iota. + destruct (_ && _ && _) eqn:BOUNDS. + + exists (Val.extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold Val.extfsl. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int64.zwordsize + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int64.zwordsize + (Z.sub + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. + simpl. + destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. + destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + constructor. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - apply DEFAULT. - TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 23514d21..e9269213 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -101,6 +101,32 @@ Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := end else Vtop. +Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | L w => + L (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + +Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | L w => + L (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -231,6 +257,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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 | _, _ => Vbot end. @@ -368,6 +396,18 @@ Proof. destruct (_ && _ && _). + inv H1; constructor. + constructor. + + (* extfzl *) + - unfold Val.extfzl, eval_static_extfzl. + destruct (_ && _ && _). + + inv H1; constructor. + + constructor. + + (* extfsl *) + - unfold Val.extfsl, eval_static_extfsl. + destruct (_ && _ && _). + + inv H1; constructor. + + constructor. Qed. End SOUNDNESS. -- cgit From bb7f6223911e354720709d623c5d9510319fb8b3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 25 Apr 2019 18:33:21 +0200 Subject: [BUGGED] First attempt at a dumb scheduler ("accumulates" instructions) --- mppa_k1c/InstructionScheduler.ml | 59 ++++++++++++++++++++++++++++++++++-- mppa_k1c/InstructionScheduler.mli | 3 ++ mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 3 files changed, 61 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index dca4b8ff..1eba01d7 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,10 +307,65 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(* FIXME DUMMY CODE to placate warnings - *) +(** FIXME - warning fix *) let _ = priority_list_scheduler INSTRUCTION_ORDER;; +type bundle = int list;; + +let rec extract_deps_to index = function + | [] -> [] + | dep :: deps -> let extracts = extract_deps_to index deps in + if (dep.instr_to == index) then + dep :: extracts + else + extracts + +exception InvalidBundle;; + +let dependency_check problem bundle index = + let index_deps = extract_deps_to index problem.latency_constraints in + List.iter (fun i -> + List.iter (fun dep -> + if (dep.instr_from == i) then raise InvalidBundle + ) index_deps + ) bundle;; + +let rec make_bundle problem resources bundle index = + let resources_copy = Array.copy resources in + let inst_usage = problem.instruction_usages.(index) in + try match vector_less_equal inst_usage resources with + | false -> raise InvalidBundle + | true -> ( + dependency_check problem bundle index; + vector_subtract problem.instruction_usages.(index) resources_copy; + make_bundle problem resources_copy (index::bundle) (index+1) + ) + with InvalidBundle -> (bundle, index);; + +let rec make_bundles problem index : bundle list = + if index >= get_nr_instructions problem then + [] + else + let (bundle, new_index) = make_bundle problem problem.resource_bounds [] index in + bundle :: (make_bundles problem new_index);; + +let bundles_to_schedule problem bundles : solution = + let nr_instructions = get_nr_instructions problem in + let schedule = Array.make nr_instructions (-1) in + let time = ref 0 in + List.iter (fun bundle -> + begin + List.iter (fun i -> + schedule.(i) <- !time + ) bundle; + time := !time + 1 + end + ) bundles; schedule;; + +let dumb_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 diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli index 629664f9..701ccb25 100644 --- a/mppa_k1c/InstructionScheduler.mli +++ b/mppa_k1c/InstructionScheduler.mli @@ -62,6 +62,9 @@ Once a clock tick is full go to the next. @return [Some solution] when a solution is found, [None] if not. *) val list_scheduler : problem -> solution option +(** Schedule the problem using the order of instructions without any reordering *) +val dumb_scheduler : problem -> solution option + (** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) val schedule_reversed : scheduler -> problem -> int array option diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 87f34ee6..decb5722 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -759,7 +759,7 @@ let do_schedule bb = in let solution = validated_scheduler (if !Clflags.option_fpostpass_ilp then cascaded_scheduler - else list_scheduler) problem + else dumb_scheduler) problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From 87615fd17854019e12a5acdebab11adc62eec5c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 26 Apr 2019 22:44:13 +0200 Subject: some little helper --- mppa_k1c/DecBoolOps.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 mppa_k1c/DecBoolOps.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/DecBoolOps.v b/mppa_k1c/DecBoolOps.v new file mode 100644 index 00000000..7f6f7c87 --- /dev/null +++ b/mppa_k1c/DecBoolOps.v @@ -0,0 +1,15 @@ +Set Implicit Arguments. + +Theorem and_dec : forall A B C D : Prop, + { A } + { B } -> { C } + { D } -> + { A /\ C } + { (B /\ C) \/ (B /\ D) \/ (A /\ D) }. +Proof. + intros A B C D AB CD. + destruct AB; destruct CD. + - left. tauto. + - right. tauto. + - right. tauto. + - right. tauto. +Qed. + + \ No newline at end of file -- cgit From 28e66eb4b60c485bebb1e217bc8f50bdc2cc6ddb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 18:18:24 +0200 Subject: moved operators to specific file instead of common file --- mppa_k1c/Asm.v | 1 + mppa_k1c/Asmvliw.v | 9 ++++---- mppa_k1c/ExtValues.v | 57 ++++++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Op.v | 26 ++++++++++----------- mppa_k1c/SelectLongproof.v | 10 ++++---- mppa_k1c/SelectOpproof.v | 9 ++++---- mppa_k1c/ValueAOp.v | 10 ++++---- 7 files changed, 91 insertions(+), 31 deletions(-) create mode 100644 mppa_k1c/ExtValues.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index ec67d703..609bf93e 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -23,6 +23,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. +Require Import ExtValues. Require Import Memory. Require Import Events. Require Import Globalenvs. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3c308960..6442cecc 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -25,6 +25,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. +Require Import ExtValues. Require Import Memory. Require Import Events. Require Import Globalenvs. @@ -883,10 +884,10 @@ Definition arith_eval_rr n v := | Pcvtl2w => Val.loword v | Psxwd => Val.longofint v | Pzxwd => Val.longofintu v - | Pextfz stop start => Val.extfz stop start v - | Pextfs stop start => Val.extfs stop start v - | Pextfzl stop start => Val.extfzl stop start v - | Pextfsl stop start => Val.extfsl stop start v + | Pextfz stop start => extfz stop start v + | Pextfs stop start => extfs stop start v + | Pextfzl stop start => extfzl stop start v + | Pextfsl stop start => extfsl stop start v | Pfnegd => Val.negf v | Pfnegw => Val.negfs v | Pfabsd => Val.absf v diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v new file mode 100644 index 00000000..d1329583 --- /dev/null +++ b/mppa_k1c/ExtValues.v @@ -0,0 +1,57 @@ +Require Import Coqlib. +Require Import Integers. +Require Import Values. + +Definition extfz stop start v := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | Vint w => + Vint (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + + +Definition extfs stop start v := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | Vint w => + Vint (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + +Definition extfzl stop start v := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | Vlong w => + Vlong (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + + +Definition extfsl stop start v := + if (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize) + then + let stop' := Z.add stop Z.one in + match v with + | Vlong w => + Vlong (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 99625f5c..d3e4270e 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -31,7 +31,7 @@ Require Import BoolEqual Coqlib. Require Import AST Integers Floats. -Require Import Values Memory Globalenvs Events. +Require Import Values ExtValues Memory Globalenvs Events. Set Implicit Arguments. @@ -502,10 +502,10 @@ Definition eval_operation | (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 (Val.extfz stop start v0) - | (Oextfs stop start), v0::nil => Some (Val.extfs stop start v0) - | (Oextfzl stop start), v0::nil => Some (Val.extfzl stop start v0) - | (Oextfsl stop start), v0::nil => Some (Val.extfsl stop start v0) + | (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) | _, _ => None end. @@ -974,22 +974,22 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (_ && _); simpl; trivial. destruct (Val.cmp_different_blocks _); simpl; trivial. (* extfz *) - - unfold Val.extfz. + - unfold extfz. destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. (* extfs *) - - unfold Val.extfs. + - unfold extfs. destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. (* extfzl *) - - unfold Val.extfzl. + - unfold extfzl. destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. (* extfsl *) - - unfold Val.extfsl. + - unfold extfsl. destruct (_ && _ && _). + destruct v0; simpl; trivial. + constructor. @@ -1604,25 +1604,25 @@ Proof. * rewrite Hcond'. constructor. (* extfz *) - - unfold Val.extfz. + - unfold extfz. destruct (_ && _ && _). + inv H4; trivial. + trivial. (* extfs *) - - unfold Val.extfs. + - unfold extfs. destruct (_ && _ && _). + inv H4; trivial. + trivial. (* extfzl *) - - unfold Val.extfzl. + - unfold extfzl. destruct (_ && _ && _). + inv H4; trivial. + trivial. (* extfsl *) - - unfold Val.extfsl. + - unfold extfsl. destruct (_ && _ && _). + inv H4; trivial. + trivial. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 451bded7..17d9d2ec 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -19,7 +19,7 @@ Require Import String Coqlib Maps Integers Floats Errors. Require Archi. -Require Import AST Values Memory Globalenvs Events. +Require Import AST Values ExtValues Memory Globalenvs Events. Require Import Cminor Op CminorSel. Require Import OpHelpers OpHelpersproof. Require Import SelectOp SelectOpproof SplitLong SplitLongproof. @@ -252,14 +252,14 @@ Proof. simpl negb. cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + + exists (extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) Z.one) Int64.zwordsize) v1). split. ++ EvalOp. - ++ unfold Val.extfzl. + ++ unfold extfzl. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int64.zwordsize @@ -304,14 +304,14 @@ Proof. simpl negb. cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + + exists (extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) Z.one) Int64.zwordsize) v1). split. ++ EvalOp. - ++ unfold Val.extfsl. + ++ unfold extfsl. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int64.zwordsize diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 4df87bea..b23e2aa8 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -23,6 +23,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. +Require Import ExtValues. Require Import Memory. Require Import Globalenvs. Require Import Cminor. @@ -311,14 +312,14 @@ Proof. simpl negb. cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + + exists (extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) Z.one) Int.zwordsize) v1). split. ++ EvalOp. - ++ unfold Val.extfz. + ++ unfold extfz. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int.zwordsize @@ -368,14 +369,14 @@ Proof. simpl negb. cbn iota. destruct (_ && _ && _) eqn:BOUNDS. - + exists (Val.extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + + exists (extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) Z.one) Int.zwordsize) v1). split. ++ EvalOp. - ++ unfold Val.extfs. + ++ unfold extfs. rewrite BOUNDS. destruct v1; try (simpl; apply Val.lessdef_undef). replace (Z.sub Int.zwordsize diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index e9269213..dfd2b78c 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -12,7 +12,7 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op RTL ValueDomain. +Require Import Op ExtValues RTL ValueDomain. (** Value analysis for RISC V operators *) @@ -386,25 +386,25 @@ Proof. constructor. (* extfz *) - - unfold Val.extfz, eval_static_extfz. + - unfold extfz, eval_static_extfz. destruct (_ && _ && _). + inv H1; constructor. + constructor. (* extfs *) - - unfold Val.extfs, eval_static_extfs. + - unfold extfs, eval_static_extfs. destruct (_ && _ && _). + inv H1; constructor. + constructor. (* extfzl *) - - unfold Val.extfzl, eval_static_extfzl. + - unfold extfzl, eval_static_extfzl. destruct (_ && _ && _). + inv H1; constructor. + constructor. (* extfsl *) - - unfold Val.extfsl, eval_static_extfsl. + - unfold extfsl, eval_static_extfsl. destruct (_ && _ && _). + inv H1; constructor. + constructor. -- cgit From 146bf43966f0d0c7a1587fc4d8dab58958d621fa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 19:23:04 +0200 Subject: factor expressions into single file --- mppa_k1c/ExtValues.v | 26 ++++++++++++++------------ mppa_k1c/Op.v | 16 ++++++++-------- mppa_k1c/SelectLong.vp | 9 +++------ mppa_k1c/SelectLongproof.v | 4 ++-- mppa_k1c/SelectOp.vp | 9 +++------ mppa_k1c/SelectOpproof.v | 4 ++-- mppa_k1c/ValueAOp.v | 24 ++++++++---------------- mppa_k1c/bitmasks.py | 12 ++++++++++++ 8 files changed, 52 insertions(+), 52 deletions(-) create mode 100755 mppa_k1c/bitmasks.py (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index d1329583..97e48eb7 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -2,10 +2,13 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Definition is_bitfield stop start := + (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize). + Definition extfz stop start v := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then let stop' := Z.add stop Z.one in match v with @@ -17,9 +20,7 @@ Definition extfz stop start v := Definition extfs stop start v := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then let stop' := Z.add stop Z.one in match v with @@ -29,10 +30,13 @@ Definition extfs stop start v := end else Vundef. +Definition is_bitfieldl stop start := + (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize). + Definition extfzl stop start v := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then let stop' := Z.add stop Z.one in match v with @@ -44,9 +48,7 @@ Definition extfzl stop start v := Definition extfsl stop start v := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then let stop' := Z.add stop Z.one in match v with diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index d3e4270e..2836f7cf 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -975,22 +975,22 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (Val.cmp_different_blocks _); simpl; trivial. (* extfz *) - unfold extfz. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + destruct v0; simpl; trivial. + constructor. (* extfs *) - unfold extfs. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + destruct v0; simpl; trivial. + constructor. (* extfzl *) - unfold extfzl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + destruct v0; simpl; trivial. + constructor. (* extfsl *) - unfold extfsl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + destruct v0; simpl; trivial. + constructor. Qed. @@ -1605,25 +1605,25 @@ Proof. (* extfz *) - unfold extfz. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + inv H4; trivial. + trivial. (* extfs *) - unfold extfs. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + inv H4; trivial. + trivial. (* extfzl *) - unfold extfzl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + inv H4; trivial. + trivial. (* extfsl *) - unfold extfsl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + inv H4; trivial. + trivial. Qed. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 90901e04..a2bc0587 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -23,6 +23,7 @@ Require Import AST Integers Floats. Require Import Op CminorSel. Require Import OpHelpers. Require Import SelectOp SplitLong. +Require Import ExtValues. Local Open Scope cminorsel_scope. Local Open Scope string_scope. @@ -158,9 +159,7 @@ Nondetfunction shrluimm (e1: expr) (n: int) := | Eop (Oshllimm n1) (t1:::Enil) => let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then Eop (Oextfzl stop start) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil) | _ => @@ -183,9 +182,7 @@ Nondetfunction shrlimm (e1: expr) (n: int) := | Eop (Oshllimm n1) (t1:::Enil) => let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then Eop (Oextfsl stop start) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil) | _ => diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 17d9d2ec..b3cb1ce0 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -251,7 +251,7 @@ Proof. - subst x. simpl negb. cbn iota. - destruct (_ && _ && _) eqn:BOUNDS. + destruct (is_bitfieldl _ _) eqn:BOUNDS. + exists (extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add @@ -303,7 +303,7 @@ Proof. - subst x. simpl negb. cbn iota. - destruct (_ && _ && _) eqn:BOUNDS. + destruct (is_bitfieldl _ _) eqn:BOUNDS. + exists (extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6bb5ee56..aad6249a 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -51,6 +51,7 @@ Require Import Floats. Require Import Op. Require Import CminorSel. Require Import OpHelpers. +Require Import ExtValues. Local Open Scope cminorsel_scope. @@ -189,9 +190,7 @@ Nondetfunction shruimm (e1: expr) (n: int) := | Eop (Oshlimm n1) (t1:::Enil) => let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then Eop (Oextfz stop start) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) | _ => @@ -213,9 +212,7 @@ Nondetfunction shrimm (e1: expr) (n: int) := | Eop (Oshlimm n1) (t1:::Enil) => let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then Eop (Oextfs stop start) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) | _ => diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index b23e2aa8..cc362eb7 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -311,7 +311,7 @@ Proof. - subst x. simpl negb. cbn iota. - destruct (_ && _ && _) eqn:BOUNDS. + destruct (is_bitfield _ _) eqn:BOUNDS. + exists (extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add @@ -368,7 +368,7 @@ Proof. - subst x. simpl negb. cbn iota. - destruct (_ && _ && _) eqn:BOUNDS. + destruct (is_bitfield _ _) eqn:BOUNDS. + exists (extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) (Z.sub (Z.add diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index dfd2b78c..b7bd6ec9 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -76,9 +76,7 @@ Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : ava Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then let stop' := Z.add stop Z.one in match v with @@ -89,9 +87,7 @@ Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := else Vtop. Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize) + if is_bitfield stop start then let stop' := Z.add stop Z.one in match v with @@ -102,9 +98,7 @@ Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := else Vtop. Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then let stop' := Z.add stop Z.one in match v with @@ -115,9 +109,7 @@ Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) := else Vtop. Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) := - if (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize) + if is_bitfieldl stop start then let stop' := Z.add stop Z.one in match v with @@ -387,25 +379,25 @@ Proof. (* extfz *) - unfold extfz, eval_static_extfz. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + inv H1; constructor. + constructor. (* extfs *) - unfold extfs, eval_static_extfs. - destruct (_ && _ && _). + destruct (is_bitfield _ _). + inv H1; constructor. + constructor. (* extfzl *) - unfold extfzl, eval_static_extfzl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + inv H1; constructor. + constructor. (* extfsl *) - unfold extfsl, eval_static_extfsl. - destruct (_ && _ && _). + destruct (is_bitfieldl _ _). + inv H1; constructor. + constructor. Qed. diff --git a/mppa_k1c/bitmasks.py b/mppa_k1c/bitmasks.py new file mode 100755 index 00000000..9f6987d6 --- /dev/null +++ b/mppa_k1c/bitmasks.py @@ -0,0 +1,12 @@ +#!/usr/bin/env python3 +def bitmask(to, fr): + bit_to = 1< Date: Sat, 27 Apr 2019 19:51:59 +0200 Subject: more base operators on bitfield --- mppa_k1c/ExtValues.v | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 97e48eb7..1348c0e8 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -30,6 +30,20 @@ Definition extfs stop start v := end else Vundef. +Definition zbitfield_mask stop start := + (Z.shiftl 1 (Z.succ stop)) - (Z.shiftl 1 start). + +Definition bitfield_mask stop start := + Vint(Int.repr (zbitfield_mask stop start)). + +Definition bitfield_maskl stop start := + Vlong(Int64.repr (zbitfield_mask stop start)). + +Definition insf stop start prev fld := + let mask := bitfield_mask stop start in + Val.or (Val.and prev (Val.notint mask)) + (Val.and (Val.shl fld (Vint (Int.repr start))) mask). + Definition is_bitfieldl stop start := (Z.leb start stop) && (Z.geb start Z.zero) @@ -57,3 +71,8 @@ Definition extfsl stop start v := | _ => Vundef end else Vundef. + +Definition insfl stop start prev fld := + let mask := bitfield_maskl stop start in + Val.orl (Val.andl prev (Val.notl mask)) + (Val.andl (Val.shll fld (Vint (Int.repr start))) mask). -- cgit From 54eb8e20fb0172aa47d1045ae56eb8fd2afe9d36 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 21:32:15 +0200 Subject: begin add bitfield insertion --- mppa_k1c/Asm.v | 7 +++++++ mppa_k1c/Asmblockdeps.v | 20 ++++++++++++++++++-- mppa_k1c/Asmvliw.v | 18 ++++++++++++++++-- mppa_k1c/PostpassSchedulingOracle.ml | 15 ++++++++++++--- mppa_k1c/TargetPrinter.ml | 2 ++ 5 files changed, 55 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 609bf93e..f1ccc126 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -137,6 +137,9 @@ Inductive instruction : Type := | 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 *) @@ -404,6 +407,10 @@ Definition basic_to_instruction (b: basic) := | 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a1a11701..8fccdd99 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -57,6 +57,7 @@ Inductive arith_op := | OArithRRI32 (n: arith_name_rri32) (imm: int) | OArithRRI64 (n: arith_name_rri64) (imm: int64) | OArithARRR (n: arith_name_arrr) + | OArithARR (n: arith_name_arr) | OArithARRI32 (n: arith_name_arri32) (imm: int) | OArithARRI64 (n: arith_name_arri64) (imm: int64) . @@ -121,6 +122,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := | OArithRRI32 n i, [Val v] => Some (Val (arith_eval_rri32 n v i)) | OArithRRI64 n i, [Val v] => Some (Val (arith_eval_rri64 n v i)) + | OArithARR n, [Val v1; Val v2] => Some (Val (arith_eval_arr n v1 v2)) | OArithARRR n, [Val v1; Val v2; Val v3] => Some (Val (arith_eval_arrr n v1 v2 v3)) | OArithARRI32 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri32 n v1 v2 i)) | OArithARRI64 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri64 n v1 v2 i)) @@ -329,6 +331,8 @@ Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o2 with OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end | OArithARRR n1 => match o2 with OArithARRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithARR n1 => + match o2 with OArithARR n2 => phys_eq n1 n2 | _ => RET false end | OArithARRI32 n1 i1 => match o2 with OArithARRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end | OArithARRI64 n1 i1 => @@ -597,6 +601,7 @@ Definition trans_arith (ai: ar_instruction) : inst := | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (PReg(#s) @ Enil))] | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (PReg(#s) @ Enil))] | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (PReg(#d) @ PReg(#s1) @ PReg(#s2) @ Enil))] + | PArithARR n d s => [(#d, Op (Arith (OArithARR n)) (PReg(#d) @ PReg(#s) @ Enil))] | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (PReg(#d) @ PReg(#s) @ Enil))] | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (PReg(#d) @ PReg(#s) @ Enil))] end. @@ -776,6 +781,12 @@ Proof. * Simpl. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. +(* PArithARR *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. (* PArithARRI32 *) - eexists; split; [|split]. * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. @@ -1344,6 +1355,12 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := | Pcmoveu _ => "Pcmoveu" end. +Definition string_of_name_arr (n: arith_name_arr): pstring := + match n with + | Pinsf _ _ => "Pinsf" + | Pinsfl _ _ => "Pinsfl" + end. + Definition string_of_name_arri32 (n: arith_name_arri32): pstring := match n with | Pmaddiw => "Pmaddw" @@ -1366,6 +1383,7 @@ Definition string_of_arith (op: arith_op): pstring := | OArithRRI32 n _ => string_of_name_rri32 n | OArithRRI64 n _ => string_of_name_rri64 n | OArithARRR n => string_of_name_arrr n + | OArithARR n => string_of_name_arr n | OArithARRI32 n _ => string_of_name_arri32 n | OArithARRI64 n _ => string_of_name_arri64 n end. @@ -1470,5 +1488,3 @@ Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. End SECT_BBLOCK_EQUIV. - - diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 6442cecc..0427d93c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -312,7 +312,7 @@ Inductive arith_name_rr : Type := | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) | Pextfzl (stop : Z) (start : Z) (**r extract bit field, unsigned *) | Pextfsl (stop : Z) (start : Z) (**r extract bit field, signed *) - + | Pfabsd (**r float absolute double *) | Pfabsw (**r float absolute word *) | Pfnegd (**r float negate double *) @@ -444,6 +444,11 @@ Inductive arith_name_arri64 : Type := | Pmaddil (**r multiply add long *) . +Inductive arith_name_arr : Type := + | Pinsf (stop : Z) (start : Z) (**r insert bit field *) + | Pinsfl (stop : Z) (start : Z) (**r insert bit field *) +. + Inductive ar_instruction : Type := | PArithR (i: arith_name_r) (rd: ireg) | PArithRR (i: arith_name_rr) (rd rs: ireg) @@ -455,6 +460,7 @@ Inductive ar_instruction : Type := | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) + | PArithARR (i: arith_name_arr) (rd rs: ireg) | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) . @@ -468,7 +474,8 @@ Coercion PArithRF64: arith_name_rf64 >-> Funclass. Coercion PArithRRR: arith_name_rrr >-> Funclass. Coercion PArithRRI32: arith_name_rri32 >-> Funclass. Coercion PArithRRI64: arith_name_rri64 >-> Funclass. -Coercion PArithARRR: arith_name_arrr >-> Funclass. +Coercion PArithARRR: arith_name_arrr >-> Funclass. +Coercion PArithARR: arith_name_arr >-> Funclass. Coercion PArithARRI32: arith_name_arri32 >-> Funclass. Coercion PArithARRI64: arith_name_arri64 >-> Funclass. @@ -1048,6 +1055,12 @@ Definition arith_eval_arrr n v1 v2 v3 := end end. +Definition arith_eval_arr n v1 v2 := + match n with + | Pinsf stop start => ExtValues.insf stop start v1 v2 + | Pinsfl stop start => ExtValues.insfl stop start v1 v2 + end. + Definition arith_eval_arri32 n v1 v2 v3 := match n with | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) @@ -1074,6 +1087,7 @@ Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := | PArithRRI64 n d s i => rsw#d <- (arith_eval_rri64 n rsr#s i) | PArithARRR n d s1 s2 => rsw#d <- (arith_eval_arrr n rsr#d rsr#s1 rsr#s2) + | PArithARR n d s => rsw#d <- (arith_eval_arr n rsr#d rsr#s) | PArithARRI32 n d s i => rsw#d <- (arith_eval_arri32 n rsr#d rsr#s i) | PArithARRI64 n d s i => rsw#d <- (arith_eval_arri64 n rsr#d rsr#s i) end. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b9344116..e0ad2357 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -130,6 +130,11 @@ let arith_rri64_str = function | Pandnil -> "Pandnil" | Pornil -> "Pornil" + +let arith_arr_str = function + | Pinsf (_, _) -> "Pinsf" + | Pinsfl (_, _) -> "Pinsfl" + let arith_arrr_str = function | Pmaddw -> "Pmaddw" | Pmaddl -> "Pmaddl" @@ -179,6 +184,8 @@ let arith_arri32_rec i rd rs imm32 = { inst = "Pmaddiw"; write_locs = [Reg rd]; 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} @@ -192,6 +199,7 @@ let arith_rec i = | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | 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)) @@ -428,7 +436,7 @@ type real_instruction = | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd | Maddw | Maddd | Cmoved - | Make | Nop | Extfz | Extfs + | Make | Nop | Extfz | Extfs | Insf (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Sb | Sh | Sw | Sd @@ -480,6 +488,7 @@ let ab_inst_to_real = function | "Pnop" | "Pcvtw2l" -> Nop | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs + | "Insf" | "Insfl" -> Insf | "Pfnarrowdw" -> Fnarrowdw | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz @@ -574,7 +583,7 @@ let rec_to_usage r = | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) - | Extfz | Extfs -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) + | 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 -> (match encoding with None | Some U6 | Some S10 -> lsu_data @@ -597,7 +606,7 @@ let real_inst_to_latency = function | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Srad | Srld | Slld | Xord | Make - | Extfs | Extfz | Fcompw | Fcompd | Cmoved + | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved -> 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 *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index f986db39..99c89804 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -381,6 +381,8 @@ module Target (*: TARGET*) = fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) | Pextfs(rd, rs, stop, start) | Pextfsl(rd, rs, stop, start) -> fprintf oc " extfs %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) + | Pinsf(rd, rs, stop, start) | Pinsfl(rd, rs, stop, start) -> + fprintf oc " insf %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) | Pfabsd(rd, rs) -> fprintf oc " fabsd %a = %a\n" ireg rd ireg rs | Pfabsw(rd, rs) -> -- cgit From 31c3ca256506274e578ccca15b7db37280ea6bd5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 22:35:51 +0200 Subject: add bitfield insert opcode but not yet used nor translated --- mppa_k1c/ExtValues.v | 14 ++++++++++---- mppa_k1c/Machregs.v | 4 +++- mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 36 +++++++++++++++++++++++++++++++++++- mppa_k1c/ValueAOp.v | 41 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 90 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 1348c0e8..58e8054f 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -41,8 +41,11 @@ Definition bitfield_maskl stop start := Definition insf stop start prev fld := let mask := bitfield_mask stop start in - Val.or (Val.and prev (Val.notint mask)) - (Val.and (Val.shl fld (Vint (Int.repr start))) mask). + if is_bitfield stop start + then + Val.or (Val.and prev (Val.notint mask)) + (Val.and (Val.shl fld (Vint (Int.repr start))) mask) + else Vundef. Definition is_bitfieldl stop start := (Z.leb start stop) @@ -74,5 +77,8 @@ Definition extfsl stop start v := Definition insfl stop start prev fld := let mask := bitfield_maskl stop start in - Val.orl (Val.andl prev (Val.notl mask)) - (Val.andl (Val.shll fld (Vint (Int.repr start))) mask). + if is_bitfieldl stop start + then + Val.orl (Val.andl prev (Val.notl mask)) + (Val.andl (Val.shll fld (Vint (Int.repr start))) mask) + else Vundef. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 06758756..ee85fb1c 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -210,7 +210,9 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => true + | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ + | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ + | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 53c9c117..abdcd94a 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -119,6 +119,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) end. Definition operation_is_redundant (op: operation) (nv: nval): bool := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 2836f7cf..093c8c17 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -201,7 +201,9 @@ Inductive operation : Type := | Oextfz (stop : Z) (start : Z) | Oextfs (stop : Z) (start : Z) | Oextfzl (stop : Z) (start : Z) - | Oextfsl (stop : Z) (start : Z). + | Oextfsl (stop : Z) (start : Z) + | Oinsf (stop : Z) (start : Z) + | Oinsfl (stop : Z) (start : Z). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -506,6 +508,8 @@ Definition eval_operation | (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) | _, _ => None end. @@ -701,6 +705,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle) | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) + | Oinsf _ _ => (Tint :: Tint :: nil, Tint) + | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -993,6 +999,18 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). destruct (is_bitfieldl _ _). + destruct v0; simpl; trivial. + constructor. + (* insf *) + - unfold insf, bitfield_mask. + destruct (is_bitfield _ _). + + destruct v0; destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + + constructor. + (* insf *) + - unfold insfl, bitfield_mask. + destruct (is_bitfieldl _ _). + + destruct v0; destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + + constructor. Qed. End SOUNDNESS. @@ -1626,6 +1644,22 @@ Proof. destruct (is_bitfieldl _ _). + inv H4; trivial. + trivial. + + (* insf *) + - unfold insf. + destruct (is_bitfield _ _). + + inv H4; inv H2; trivial. + simpl. destruct (Int.ltu _ _); trivial. + simpl. trivial. + + trivial. + + (* insfl *) + - unfold insfl. + destruct (is_bitfieldl _ _). + + inv H4; inv H2; trivial. + simpl. destruct (Int.ltu _ _); trivial. + simpl. trivial. + + trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index b7bd6ec9..fe8bddcf 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -119,6 +119,34 @@ Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) := end else Vtop. +Definition eval_static_insf stop start prev fld := + let mask := Int.repr (zbitfield_mask stop start) in + if is_bitfield stop start + then + match prev, fld with + | (I prevI), (I fldI) => + if Int.ltu (Int.repr start) Int.iwordsize + then I (Int.or (Int.and prevI (Int.not mask)) + (Int.and (Int.shl fldI (Int.repr start)) mask)) + else Vtop + | _, _ => Vtop + end + else Vtop. + +Definition eval_static_insfl stop start prev fld := + let mask := Int64.repr (zbitfield_mask stop start) in + if is_bitfieldl stop start + then + match prev, fld with + | (L prevL), (L fldL) => + if Int.ltu (Int.repr start) Int64.iwordsize' + then L (Int64.or (Int64.and prevL (Int64.not mask)) + (Int64.and (Int64.shl' fldL (Int.repr start)) mask)) + else Vtop + | _,_ => Vtop + end + else Vtop. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -251,6 +279,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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 | _, _ => Vbot end. @@ -400,6 +430,17 @@ Proof. destruct (is_bitfieldl _ _). + inv H1; constructor. + constructor. + + (* insf *) + - unfold insf, eval_static_insf. + destruct (is_bitfield _ _). + + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + + constructor. + (* insfl *) + - unfold insfl, eval_static_insfl. + destruct (is_bitfieldl _ _). + + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + + constructor. Qed. End SOUNDNESS. -- cgit From 7331395825deb5eb4478dffb070dd7d673e657cc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 22:44:21 +0200 Subject: some more folding of code --- mppa_k1c/Asmblockgen.v | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 6af18178..d6e168bb 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -21,6 +21,7 @@ Require Archi. Require Import Coqlib Errors. Require Import AST Integers Floats Memdata. Require Import Op Locations Machblock Asmblock. +Require ExtValues. Local Open Scope string_scope. Local Open Scope error_monad_scope. @@ -773,18 +774,24 @@ Definition transl_op end) | Oextfz stop start, a1 :: nil => - assertion ((Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize)); + assertion (ExtValues.is_bitfield stop start); do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pextfz stop start rd rs ::i k) | Oextfs stop start, a1 :: nil => - assertion ((Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize)); + assertion (ExtValues.is_bitfield stop start); do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pextfs stop start rd rs ::i k) + + | Oextfzl stop start, a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfzl stop start rd rs ::i k) + + | Oextfsl stop start, a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfsl stop start rd rs ::i k) | _, _ => Error(msg "Asmgenblock.transl_op") -- cgit From c647ca1fa4edc09bea86d5088c2956954269ffa7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 22:50:24 +0200 Subject: instruction translation for bitfield insertion --- mppa_k1c/Asmblockgen.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index d6e168bb..80210f7f 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -793,6 +793,18 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pextfsl stop start rd rs ::i k) + | Oinsf stop start, a0 :: a1 :: nil => + assertion (ExtValues.is_bitfield stop start); + assertion (mreg_eq a0 res); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pinsf stop start rd rs ::i k) + + | Oinsfl stop start, a0 :: a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + assertion (mreg_eq a0 res); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pinsfl stop start rd rs ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. -- cgit From 13a7c021f6447cebbb6bf2716bedb7f9bcb5ddd3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 27 Apr 2019 23:11:17 +0200 Subject: compute the highest bit in a number --- mppa_k1c/ExtValues.v | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 58e8054f..2faa6b0a 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -82,3 +82,13 @@ Definition insfl stop start prev fld := Val.orl (Val.andl prev (Val.notl mask)) (Val.andl (Val.shll fld (Vint (Int.repr start))) mask) else Vundef. + +Fixpoint highest_bit (x : Z) (n : nat) : N := + match n with + | O => 0%N + | S n1 => + let n' := N_of_nat n in + if Z.testbit x (Z.of_N n') + then n' + else highest_bit x n1 + end. -- cgit From 1faf4e651144cfdc40fd797d5ff9be388236d34f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 08:19:29 +0200 Subject: detect insf case, begin --- mppa_k1c/ExtValues.v | 15 +++++++++++---- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 1 + 3 files changed, 16 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 2faa6b0a..fe8ce203 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -83,12 +83,19 @@ Definition insfl stop start prev fld := (Val.andl (Val.shll fld (Vint (Int.repr start))) mask) else Vundef. -Fixpoint highest_bit (x : Z) (n : nat) : N := +Fixpoint highest_bit (x : Z) (n : nat) : Z := match n with - | O => 0%N + | O => 0 | S n1 => - let n' := N_of_nat n in - if Z.testbit x (Z.of_N n') + let n' := Z.of_N (N_of_nat n) in + if Z.testbit x n' then n' else highest_bit x n1 end. + +Definition int_highest_bit (x : int) : Z := + highest_bit (Int.unsigned x) (31%nat). + + +Definition int64_highest_bit (x : int64) : Z := + highest_bit (Int64.unsigned x) (63%nat). diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index aad6249a..bdceced8 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -336,6 +336,10 @@ Nondetfunction or (e1: expr) (e2: expr) := && 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)) => + Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index cc362eb7..dc8f16ab 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -701,6 +701,7 @@ Proof. rewrite Int.or_zero. reflexivity. - apply DEFAULT. + - apply DEFAULT. Qed. Theorem eval_xorimm: -- cgit From e20c75e0d54c38b5fab9cb12058b9918ceff3ae4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 08:48:15 +0200 Subject: progress on bitfield detection --- mppa_k1c/SelectOp.vp | 7 ++++++- mppa_k1c/SelectOpproof.v | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index bdceced8..2987fd1d 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -339,7 +339,12 @@ Nondetfunction or (e1: expr) (e2: expr) := | (Eop (Oandimm nmask) (prev:::Enil)), (Eop (Oandimm mask) ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => - Eop Oor (e1:::e2:::Enil) + let zstart := Int.unsigned start in + let zstop := int_highest_bit mask in + let mask' := Int.repr (zbitfield_mask zstop zstart) in + if Int.eq_dec mask mask' + then Eop Oor (e1:::e2:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index dc8f16ab..1bd727b9 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -700,7 +700,7 @@ Proof. rewrite Int.or_commut. rewrite Int.or_zero. reflexivity. - - apply DEFAULT. + - destruct (Int.eq_dec _ _); apply DEFAULT. - apply DEFAULT. Qed. -- cgit From 39ee073b53eb49328cbd5d3d09375030f321424e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 09:05:14 +0200 Subject: some more on bit fields insert detection --- mppa_k1c/SelectOp.vp | 4 +++- mppa_k1c/SelectOpproof.v | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2987fd1d..2bd51f97 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -52,6 +52,7 @@ Require Import Op. Require Import CminorSel. Require Import OpHelpers. Require Import ExtValues. +Require Import DecBoolOps. Local Open Scope cminorsel_scope. @@ -342,7 +343,8 @@ Nondetfunction or (e1: expr) (e2: expr) := let zstart := Int.unsigned start in let zstop := int_highest_bit mask in let mask' := Int.repr (zbitfield_mask zstop zstart) in - if Int.eq_dec mask mask' + if and_dec (Int.eq_dec mask mask') + (Int.eq_dec nmask (Int.not mask')) then Eop Oor (e1:::e2:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 1bd727b9..b8f37c7b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -33,6 +33,7 @@ Require Import SelectOp. Require Import Events. Require Import OpHelpers. Require Import OpHelpersproof. +Require Import DecBoolOps. Local Open Scope cminorsel_scope. Local Open Scope string_scope. @@ -700,7 +701,7 @@ Proof. rewrite Int.or_commut. rewrite Int.or_zero. reflexivity. - - destruct (Int.eq_dec _ _); apply DEFAULT. + - destruct (and_dec _ _); apply DEFAULT. - apply DEFAULT. Qed. -- cgit From 19908e4a6813dc54d72d142a93a77fe41eed95a2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 09:15:00 +0200 Subject: some more on bitfield detection --- mppa_k1c/SelectOp.vp | 11 +++++++---- mppa_k1c/SelectOpproof.v | 4 +++- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2bd51f97..d0bd4f2d 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -342,10 +342,13 @@ Nondetfunction or (e1: expr) (e2: expr) := ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => let zstart := Int.unsigned start in let zstop := int_highest_bit mask in - let mask' := Int.repr (zbitfield_mask zstop zstart) in - if and_dec (Int.eq_dec mask mask') - (Int.eq_dec nmask (Int.not mask')) - then Eop Oor (e1:::e2:::Enil) + if is_bitfield zstop zstart + then + let mask' := Int.repr (zbitfield_mask zstop zstart) in + if and_dec (Int.eq_dec mask mask') + (Int.eq_dec nmask (Int.not mask')) + then Eop Oor (e1:::e2:::Enil) + else Eop Oor (e1:::e2:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index b8f37c7b..313786c8 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -701,7 +701,9 @@ Proof. rewrite Int.or_commut. rewrite Int.or_zero. reflexivity. - - destruct (and_dec _ _); apply DEFAULT. + - destruct (is_bitfield _ _). + + destruct (and_dec _ _); apply DEFAULT. + + apply DEFAULT. - apply DEFAULT. Qed. -- cgit From f0448bf49ee21ff327c98808a02824bd1536a1ee Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 11:06:37 +0200 Subject: selection for insf --- mppa_k1c/SelectOp.vp | 2 +- mppa_k1c/SelectOpproof.v | 22 ++++++++++++++++++++-- 2 files changed, 21 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d0bd4f2d..bfbd36d5 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -347,7 +347,7 @@ Nondetfunction or (e1: expr) (e2: expr) := let mask' := Int.repr (zbitfield_mask zstop zstart) in if and_dec (Int.eq_dec mask mask') (Int.eq_dec nmask (Int.not mask')) - then Eop Oor (e1:::e2:::Enil) + then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) else Eop Oor (e1:::e2:::Enil) else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 313786c8..8bfcf1b2 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -701,8 +701,26 @@ Proof. rewrite Int.or_commut. rewrite Int.or_zero. reflexivity. - - destruct (is_bitfield _ _). - + destruct (and_dec _ _); apply DEFAULT. + - set (zstop := (int_highest_bit mask)). + set (zstart := (Int.unsigned start)). + destruct (is_bitfield _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * simpl in H6. + injection H6. + clear H6. + intro. subst y. subst x. + TrivialExists. simpl. f_equal. + unfold insf. + rewrite Risbitfield. + rewrite Rmask. + rewrite Rnmask. + simpl. + unfold bitfield_mask. + subst v0. + subst zstart. + rewrite Int.repr_unsigned. + reflexivity. + * apply DEFAULT. + apply DEFAULT. - apply DEFAULT. Qed. -- cgit From 3f9395b516cfee4237483229503898cad5ab0716 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 11:10:06 +0200 Subject: insf seems to work --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index e0ad2357..7a9e683d 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -488,7 +488,7 @@ let ab_inst_to_real = function | "Pnop" | "Pcvtw2l" -> Nop | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs - | "Insf" | "Insfl" -> Insf + | "Pinsf" | "Pinsfl" -> Insf | "Pfnarrowdw" -> Fnarrowdw | "Pfwidenlwd" -> Fwidenlwd | "Pfloatwrnsz" -> Floatwz -- cgit From 6d904a7952816b1e1c6ba5c560e938713f2093db Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 12:10:21 +0200 Subject: coq mode for emacs --- mppa_k1c/SelectOp.vp | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index bfbd36d5..d32a7b85 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -604,3 +604,7 @@ Definition divfs_base (e1: expr) (e2: expr) := (* Eop Odivf (e1 ::: e2 ::: Enil). *) Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). End SELECT. + +(* Local Variables: *) +(* mode: coq *) +(* End: *) \ No newline at end of file -- cgit From ac205c117a809aa40132f4184d04371e0e467b6c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 28 Apr 2019 12:51:18 +0200 Subject: more insf detection --- mppa_k1c/SelectOp.vp | 12 ++++++++++++ mppa_k1c/SelectOpproof.v | 31 +++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index d32a7b85..e1aaf588 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -350,6 +350,18 @@ Nondetfunction or (e1: expr) (e2: expr) := then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) else Eop Oor (e1:::e2:::Enil) else Eop Oor (e1:::e2:::Enil) + | (Eop (Oandimm nmask) (prev:::Enil)), + (Eop (Oandimm mask) (fld:::Enil)) => + let zstart := 0 in + let zstop := int_highest_bit mask in + if is_bitfield zstop zstart + then + let mask' := Int.repr (zbitfield_mask zstop zstart) in + if and_dec (Int.eq_dec mask mask') + (Int.eq_dec nmask (Int.not mask')) + then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) + else Eop Oor (e1:::e2:::Enil) + else Eop Oor (e1:::e2:::Enil) | _, _ => Eop Oor (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 8bfcf1b2..c94f9c0c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -722,6 +722,37 @@ Proof. reflexivity. * apply DEFAULT. + apply DEFAULT. + - set (zstop := (int_highest_bit mask)). + set (zstart := 0). + destruct (is_bitfield _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * subst y. subst x. + TrivialExists. simpl. f_equal. + unfold insf. + rewrite Risbitfield. + rewrite Rmask. + rewrite Rnmask. + simpl. + unfold bitfield_mask. + subst zstart. + rewrite (Val.or_commut (Val.and v1 _)). + rewrite (Val.or_commut (Val.and v1 _)). + destruct v0; simpl; trivial. + unfold Int.ltu, Int.iwordsize, Int.zwordsize. + rewrite Int.unsigned_repr. + ** rewrite Int.unsigned_repr. + *** simpl. + rewrite Int.shl_zero. + reflexivity. + *** simpl. + unfold Int.max_unsigned, Int.modulus. + simpl. + omega. + ** unfold Int.max_unsigned, Int.modulus. + simpl. + omega. + * apply DEFAULT. + + apply DEFAULT. - apply DEFAULT. Qed. -- cgit From 2c7b68275dd09d700e7f8b70cf5ec091336fc1c9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 07:27:54 +0200 Subject: insfl generation --- mppa_k1c/SelectLong.vp | 30 +++++++++++++++++++++++++ mppa_k1c/SelectLongproof.v | 56 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 86 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index a2bc0587..3b9e5bf9 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -24,6 +24,7 @@ Require Import Op CminorSel. Require Import OpHelpers. Require Import SelectOp SplitLong. Require Import ExtValues. +Require Import DecBoolOps. Local Open Scope cminorsel_scope. Local Open Scope string_scope. @@ -311,6 +312,31 @@ Nondetfunction orl (e1: expr) (e2: expr) := && 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)) => + let zstart := Int.unsigned start in + let zstop := int64_highest_bit mask in + if is_bitfieldl zstop zstart + then + let mask' := Int64.repr (zbitfield_mask zstop zstart) in + if and_dec (Int64.eq_dec mask mask') + (Int64.eq_dec nmask (Int64.not mask')) + then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) + else Eop Oorl (e1:::e2:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | (Eop (Oandlimm nmask) (prev:::Enil)), + (Eop (Oandlimm mask) (fld:::Enil)) => + let zstart := 0 in + let zstop := int64_highest_bit mask in + if is_bitfieldl zstop zstart + then + let mask' := Int64.repr (zbitfield_mask zstop zstart) in + if and_dec (Int64.eq_dec mask mask') + (Int64.eq_dec nmask (Int64.not mask')) + then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) + else Eop Oorl (e1:::e2:::Enil) + else Eop Oorl (e1:::e2:::Enil) | _, _ => Eop Oorl (e1:::e2:::Enil) end. @@ -421,3 +447,7 @@ Definition singleoflong (e: expr) := SplitLong.singleoflong e. Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. End SELECT. + +(* Local Variables: *) +(* mode: coq *) +(* End: *) \ No newline at end of file diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index b3cb1ce0..cf8eed2b 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -24,6 +24,7 @@ Require Import Cminor Op CminorSel. Require Import OpHelpers OpHelpersproof. Require Import SelectOp SelectOpproof SplitLong SplitLongproof. Require Import SelectLong. +Require Import DecBoolOps. Local Open Scope cminorsel_scope. Local Open Scope string_scope. @@ -588,6 +589,61 @@ Proof. rewrite Int64.and_zero. rewrite Int64.or_zero. reflexivity. + + - (*insfl first case*) + destruct (is_bitfieldl _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * rewrite Rnmask in *. + inv H. inv H0. inv H4. inv H3. inv H9. inv H8. + simpl in H6, H7. + inv H6. inv H7. + inv H4. inv H3. inv H7. + simpl in H6. + inv H6. + set (zstop := (int64_highest_bit mask)) in *. + set (zstart := (Int.unsigned start)) in *. + + TrivialExists. + simpl. f_equal. + + unfold insfl. + rewrite Risbitfield. + rewrite Rmask. + simpl. + unfold bitfield_maskl. + subst zstart. + rewrite Int.repr_unsigned. + reflexivity. + * TrivialExists. + + TrivialExists. + - destruct (is_bitfieldl _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * rewrite Rnmask in *. + inv H. inv H0. inv H4. inv H6. inv H8. inv H3. inv H8. + inv H0. simpl in H7. inv H7. + set (zstop := (int64_highest_bit mask)) in *. + set (zstart := 0) in *. + + TrivialExists. simpl. f_equal. + unfold insfl. + rewrite Risbitfield. + rewrite Rmask. + simpl. + subst zstart. + f_equal. + destruct v0; simpl; trivial. + unfold Int.ltu, Int64.iwordsize', Int64.zwordsize, Int64.wordsize. + rewrite Int.unsigned_repr. + ** rewrite Int.unsigned_repr. + *** simpl. + rewrite Int64.shl'_zero. + reflexivity. + *** simpl. unfold Int.max_unsigned. unfold Int.modulus. + simpl. omega. + ** unfold Int.max_unsigned. unfold Int.modulus. + simpl. omega. + * TrivialExists. + + TrivialExists. - TrivialExists. Qed. -- cgit From cd3642815d4260a9e7868fce3fb6a4a8a8ea8746 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 10:29:00 +0200 Subject: Srsd / Srsw --- mppa_k1c/Asm.v | 8 ++++++++ mppa_k1c/Asmblockdeps.v | 4 ++++ mppa_k1c/Asmvliw.v | 8 ++++++++ mppa_k1c/ExtValues.v | 18 ++++++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 14 +++++++++----- mppa_k1c/TargetPrinter.ml | 8 ++++++++ 6 files changed, 55 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f1ccc126..53747851 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -189,6 +189,7 @@ Inductive instruction : Type := | 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 *) @@ -207,6 +208,7 @@ Inductive instruction : Type := | 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 *) @@ -230,11 +232,13 @@ Inductive instruction : Type := | 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 *) @@ -343,6 +347,7 @@ Definition basic_to_instruction (b: basic) := | 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 @@ -360,6 +365,7 @@ Definition basic_to_instruction (b: basic) := | 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 @@ -381,11 +387,13 @@ Definition basic_to_instruction (b: basic) := | 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 *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 8fccdd99..ff625bdd 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1287,6 +1287,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pornw => "Pornw" | Psraw => "Psraw" | Psrlw => "Psrlw" + | Psrxw => "Psrxw" | Psllw => "Psllw" | Paddl => "Paddl" | Psubl => "Psubl" @@ -1301,6 +1302,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pmull => "Pmull" | Pslll => "Pslll" | Psrll => "Psrll" + | Psrxl => "Psrxl" | Psral => "Psral" | Pfaddd => "Pfaddd" | Pfaddw => "Pfaddw" @@ -1325,11 +1327,13 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := | Porniw => "Porniw" | Psraiw => "Psraiw" | Psrliw => "Psrliw" + | Psrxiw => "Psrxiw" | Pslliw => "Pslliw" | Proriw => "Proriw" | Psllil => "Psllil" | Psrlil => "Psrlil" | Psrail => "Psrail" + | Psrxil => "Psrxil" end. Definition string_of_name_rri64 (n: arith_name_rri64): pstring := diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 0427d93c..3f2179c2 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -367,6 +367,7 @@ Inductive arith_name_rrr : Type := | Pandnw (**r andn word *) | Pornw (**r orn word *) | Psraw (**r shift right arithmetic word *) + | Psrxw (**r shift right arithmetic word round to 0*) | Psrlw (**r shift right logical word *) | Psllw (**r shift left logical word *) @@ -383,6 +384,7 @@ Inductive arith_name_rrr : Type := | Pmull (**r mul long (low part) *) | Pslll (**r shift left logical long *) | Psrll (**r shift right logical long *) + | Psrxl (**r shift right logical long round to 0*) | Psral (**r shift right arithmetic long *) | Pfaddd (**r float add double *) @@ -407,12 +409,14 @@ Inductive arith_name_rri32 : Type := | Pandniw (**r andn word *) | Porniw (**r orn word *) | Psraiw (**r shift right arithmetic imm word *) + | Psrxiw (**r shift right arithmetic imm word round to 0*) | Psrliw (**r shift right logical imm word *) | Pslliw (**r shift left logical imm word *) | Proriw (**r rotate right imm word *) | Psllil (**r shift left logical immediate long *) | Psrlil (**r shift right logical immediate long *) | Psrail (**r shift right arithmetic immediate long *) + | Psrxil (**r shift right arithmetic immediate long round to 0*) . Inductive arith_name_rri64 : Type := @@ -956,6 +960,7 @@ Definition arith_eval_rrr n v1 v2 := | Psrlw => Val.shru v1 v2 | Psraw => Val.shr v1 v2 | Psllw => Val.shl v1 v2 + | Psrxw => ExtValues.val_shrx v1 v2 | Paddl => Val.addl v1 v2 | Psubl => Val.subl v1 v2 @@ -971,6 +976,7 @@ Definition arith_eval_rrr n v1 v2 := | Pslll => Val.shll v1 v2 | Psrll => Val.shrlu v1 v2 | Psral => Val.shrl v1 v2 + | Psrxl => ExtValues.val_shrxl v1 v2 | Pfaddd => Val.addf v1 v2 | Pfaddw => Val.addfs v1 v2 @@ -994,10 +1000,12 @@ Definition arith_eval_rri32 n v i := | Pandniw => Val.and (Val.notint v) (Vint i) | Porniw => Val.or (Val.notint v) (Vint i) | Psraiw => Val.shr v (Vint i) + | Psrxiw => ExtValues.val_shrx v (Vint i) | Psrliw => Val.shru v (Vint i) | Pslliw => Val.shl v (Vint i) | Proriw => Val.ror v (Vint i) | Psllil => Val.shll v (Vint i) + | Psrxil => ExtValues.val_shrxl v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) end. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index fe8ce203..5d16b79c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -99,3 +99,21 @@ Definition int_highest_bit (x : int) : Z := Definition int64_highest_bit (x : int64) : Z := highest_bit (Int64.unsigned x) (63%nat). + +Definition val_shrx (v1 v2: val): val := + match v1, v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 31) + then Vint(Int.shrx n1 n2) + else Vundef + | _, _ => Vundef + end. + +Definition val_shrxl (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vint n2 => + if Int.ltu n2 (Int.repr 63) + then Vlong(Int64.shrx' n1 n2) + else Vundef + | _, _ => Vundef + end. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 7a9e683d..5f016e53 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -75,6 +75,7 @@ let arith_rrr_str = function | Pornw -> "Pornw" | Psraw -> "Psraw" | Psrlw -> "Psrlw" + | Psrxw -> "Psrxw" | Psllw -> "Psllw" | Paddl -> "Paddl" | Psubl -> "Psubl" @@ -89,6 +90,7 @@ let arith_rrr_str = function | Pmull -> "Pmull" | Pslll -> "Pslll" | Psrll -> "Psrll" + | Psrxl -> "Psrxl" | Psral -> "Psral" | Pfaddd -> "Pfaddd" | Pfaddw -> "Pfaddw" @@ -110,12 +112,14 @@ let arith_rri32_str = function | 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" @@ -432,8 +436,8 @@ let lsu_data_y : int array = let resmap = fun r -> match r with type real_instruction = (* ALU *) - | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Rorw | Xorw - | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Xord + | 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 @@ -580,7 +584,7 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld | Srsd -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) @@ -601,11 +605,11 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srlw | Sllw | Xorw + | Addw | Andw | Compw | Orw | Sbfw | 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 | Srld | Slld | Xord | Make + | Addd | Andd | Compd | Ord | Sbfd | Srad | Srsd | Srld | Slld | Xord | Make | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 99c89804..8e8efefc 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -471,6 +471,8 @@ module Target (*: TARGET*) = fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psraw (rd, rs1, rs2) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrxw (rd, rs1, rs2) -> + fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrlw (rd, rs1, rs2) -> fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psllw (rd, rs1, rs2) -> @@ -504,6 +506,8 @@ module Target (*: TARGET*) = fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psrll (rd, rs1, rs2) -> fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrxl (rd, rs1, rs2) -> + fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Psral (rd, rs1, rs2) -> fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmaddl (rd, rs1, rs2) -> @@ -547,6 +551,8 @@ module Target (*: TARGET*) = fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psraiw (rd, rs, imm) -> fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psrxiw (rd, rs, imm) -> + fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs coqint imm | Psrliw (rd, rs, imm) -> fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pslliw (rd, rs, imm) -> @@ -562,6 +568,8 @@ module Target (*: TARGET*) = fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Psrail (rd, rs, imm) -> fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psrxil (rd, rs, imm) -> + fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs coqint64 imm (* Arith RRI64 instructions *) | Pcompil (it, rd, rs, imm) -> -- cgit From ec99800447f584e31523345469cee96977266327 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 11:39:44 +0200 Subject: begin using shrx --- mppa_k1c/Asmblockgen.v | 6 +----- mppa_k1c/Asmblockgenproof1.v | 33 +++++++++------------------------ 2 files changed, 10 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 80210f7f..835b8a8c 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -519,11 +519,7 @@ Definition transl_op OK (Psrliw rd rs n ::i k) | Oshrximm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs ::i k else - Psraiw RTMP rs (Int.repr 31) ::i - Psrliw RTMP RTMP (Int.sub Int.iwordsize n) ::i - Paddw RTMP rs RTMP ::i - Psraiw rd RTMP n ::i k) + OK (Psrxiw rd rs n ::i k) | Ororimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Proriw rd rs n ::i k) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index bbcffbe2..a2f11154 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1593,31 +1593,16 @@ Opaque Int.eq. 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 *) - clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. - split; intros; Simpl. -+ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). econstructor; split. - eapply exec_straight_step. simpl; reflexivity. - eapply exec_straight_step. simpl; reflexivity. - eapply exec_straight_step. simpl; reflexivity. - apply exec_straight_one. simpl; reflexivity. - split; intros; Simpl. -(* - (* Ocast32signed *) - exploit cast32signed_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. split. apply B. - intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } - apply C; auto. - *)(* - (* longofintu *) - econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. - split; intros; Simpl. (* unfold Pregmap.set; Simpl. *) destruct (PregEq.eq x0 x0). - + destruct (rs x0); auto. simpl. - assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. - rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. - + contradict n. auto. *) + + apply exec_straight_one. simpl. eauto. + + split. + * rewrite Pregmap.gss. + subst v. + destruct (rs x0); simpl; trivial. + unfold Val.maketotal. + destruct (Int.ltu _ _); simpl; trivial. + * intros. + rewrite Pregmap.gso; trivial. - (* Oshrxlimm *) clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. destruct (Int.eq n Int.zero). -- cgit From 5c42545efcde8cda26a64f13ee6a1524fb17bc69 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 11:45:16 +0200 Subject: forgot in oracle --- mppa_k1c/PostpassSchedulingOracle.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 5f016e53..af40d4d1 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -473,6 +473,8 @@ let ab_inst_to_real = function | "Psubl" | "Pnegl" -> Sbfd | "Psraw" | "Psraiw" -> Sraw | "Psral" | "Psrail" -> Srad + | "Psrxw" | "Psrxiw" -> Srsw + | "Psrxl" | "Psrxil" -> Srsd | "Psrlw" | "Psrliw" -> Srlw | "Psrll" | "Psrlil" -> Srld | "Psllw" | "Pslliw" -> Sllw -- cgit From 9d8fcdd62607141814089bfa407d3dae63afa0b6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 11:49:21 +0200 Subject: srsd --- mppa_k1c/Asmblockgen.v | 6 +----- mppa_k1c/Asmblockgenproof1.v | 20 +++++++++----------- 2 files changed, 10 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 835b8a8c..49f6e4f9 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -641,11 +641,7 @@ Definition transl_op OK (Psrlil rd rs n ::i k) | Oshrxlimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero then Pmv rd rs ::i k else - Psrail RTMP rs (Int.repr 63) ::i - Psrlil RTMP RTMP (Int.sub Int64.iwordsize' n) ::i - Paddl RTMP rs RTMP ::i - Psrail rd RTMP n ::i k) + OK (Psrxil rd rs n ::i k) | Omaddl, a1 :: a2 :: a3 :: nil => assertion (mreg_eq a1 res); do r1 <- ireg_of a1; diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index a2f11154..40f9f08b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1604,18 +1604,16 @@ Opaque Int.eq. * intros. rewrite Pregmap.gso; trivial. - (* Oshrxlimm *) - clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. - split; intros; Simpl. -+ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). econstructor; split. - eapply exec_straight_step. simpl; reflexivity. - eapply exec_straight_step. simpl; reflexivity. - eapply exec_straight_step. simpl; reflexivity. - apply exec_straight_one. simpl; reflexivity. - - split; intros; Simpl. + + apply exec_straight_one. simpl. eauto. + + split. + * rewrite Pregmap.gss. + subst v. + destruct (rs x0); simpl; trivial. + unfold Val.maketotal. + 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. -- cgit From 76a75a7fa3d4f8a81868a00af99c449f1ce519b9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 14:02:17 +0200 Subject: float of intu = float of longu o longu of intu --- mppa_k1c/SelectOp.vp | 2 +- mppa_k1c/SelectOpproof.v | 20 +++++++++++++++++--- 2 files changed, 18 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index e1aaf588..1af0cd38 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -558,7 +558,7 @@ Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). Nondetfunction floatofintu (e: expr) := match e with | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil - | _ => Eop Ofloatofintu (e ::: Enil) + | _ => Eop Ofloatoflongu ((Eop Ocast32unsigned (e ::: Enil)) ::: Enil) end. Nondetfunction floatofint (e: expr) := diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index c94f9c0c..e07bc51c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1155,9 +1155,23 @@ Theorem eval_floatofintu: Val.floatofintu x = Some y -> exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. Proof. - intros until y; unfold floatofintu. case (floatofintu_match a); intros. - InvEval. simpl in H0. TrivialExists. - TrivialExists. + intros. + unfold Val.floatofintu in *. + unfold floatofintu. + destruct (floatofintu_match a). + - InvEval. + TrivialExists. + - InvEval. + TrivialExists. + constructor. econstructor. constructor. eassumption. constructor. + simpl. f_equal. constructor. + simpl. + destruct x; simpl; trivial. + f_equal. + inv H0. + f_equal. + rewrite Float.of_intu_of_longu. + reflexivity. Qed. Theorem eval_floatofint: -- cgit From 9dadf82c52a9ad11b31b21986bc88a108b845d0b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 14:10:47 +0200 Subject: float of int = float of long o long of int --- mppa_k1c/SelectOp.vp | 2 +- mppa_k1c/SelectOpproof.v | 19 ++++++++++++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 1af0cd38..25f09e2e 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -564,7 +564,7 @@ Nondetfunction floatofintu (e: expr) := Nondetfunction floatofint (e: expr) := match e with | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil - | _ => Eop Ofloatofint (e ::: Enil) + | _ => Eop Ofloatoflong ((Eop Ocast32signed (e ::: Enil)) ::: Enil) end. Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index e07bc51c..6fa93fd8 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1180,9 +1180,22 @@ Theorem eval_floatofint: Val.floatofint x = Some y -> exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. Proof. - intros until y; unfold floatofint. case (floatofint_match a); intros. - InvEval. simpl in H0. TrivialExists. - TrivialExists. + intros. + unfold floatofint. + destruct (floatofint_match a). + - InvEval. + TrivialExists. + - InvEval. + TrivialExists. + constructor. econstructor. constructor. eassumption. constructor. + simpl. f_equal. constructor. + simpl. + destruct x; simpl; trivial. + f_equal. + inv H0. + f_equal. + rewrite Float.of_int_of_long. + reflexivity. Qed. Theorem eval_intofsingle: -- cgit From 138f4fb80d3dc6cce396dc57e64c28dc949ab94a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 14:32:06 +0200 Subject: removed fake ops for int32 -> double --- mppa_k1c/Asm.v | 4 ---- mppa_k1c/Asmblockdeps.v | 2 -- mppa_k1c/Asmblockgen.v | 6 ------ mppa_k1c/Asmvliw.v | 4 ---- mppa_k1c/PostpassSchedulingOracle.ml | 4 ---- mppa_k1c/TargetPrinter.ml | 4 ---- 6 files changed, 24 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 53747851..d1ac8a67 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -149,9 +149,7 @@ Inductive instruction : Type := | 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) *) - | Pfloatudrnsz_i32 (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (32 bits) *) | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfloatdrnsz_i32 (rd rs: ireg) (**r Floating Point Conversion from integer (32 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) *) @@ -309,8 +307,6 @@ Definition basic_to_instruction (b: basic) := | 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.Pfloatudrnsz_i32 rd rs => Pfloatudrnsz_i32 rd rs - | PArithRR Asmvliw.Pfloatdrnsz_i32 rd rs => Pfloatdrnsz_i32 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index ff625bdd..2e83fb44 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1237,9 +1237,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Pfloatwrnsz => "Pfloatwrnsz" | Pfloatuwrnsz => "Pfloatuwrnsz" | Pfloatudrnsz => "Pfloatudrnsz" - | Pfloatudrnsz_i32 => "Pfloatudrnsz_i32" | Pfloatdrnsz => "Pfloatdrnsz" - | Pfloatdrnsz_i32 => "Pfloatdrnsz_i32" | Pfixedwrzz => "Pfixedwrzz" | Pfixeduwrzz => "Pfixeduwrzz" | Pfixeddrzz => "Pfixeddrzz" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 49f6e4f9..6cd31468 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -696,12 +696,6 @@ Definition transl_op | Ofloatoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatudrnsz rd rs ::i k) - | Ofloatofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatdrnsz_i32 rd rs ::i k) - | Ofloatofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatudrnsz_i32 rd rs ::i k) | Ointofsingle, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; OK (Pfixedwrzz rd rs ::i k) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3f2179c2..cf827818 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -322,9 +322,7 @@ Inductive arith_name_rr : Type := | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) - | Pfloatudrnsz_i32 (**r Floating Point Conversion from integer (unsigned int -> float) *) | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) - | Pfloatdrnsz_i32 (**r Floating Point Conversion from integer (int -> float) *) | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) @@ -909,8 +907,6 @@ Definition arith_eval_rr n v := | Pfloatuwrnsz => match Val.singleofintu v with Some f => f | _ => Vundef end | Pfloatudrnsz => match Val.floatoflongu v with Some f => f | _ => Vundef end | Pfloatdrnsz => match Val.floatoflong v with Some f => f | _ => Vundef end - | Pfloatudrnsz_i32 => match Val.floatofintu v with Some f => f | _ => Vundef end - | Pfloatdrnsz_i32 => match Val.floatofint v with Some f => f | _ => Vundef end | Pfixedwrzz => match Val.intofsingle v with Some i => i | _ => Vundef end | Pfixeduwrzz => match Val.intuofsingle v with Some i => i | _ => Vundef end | Pfixeddrzz => match Val.longoffloat v with Some i => i | _ => Vundef end diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index af40d4d1..f931b64b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -46,10 +46,8 @@ let arith_rr_str = function | Pfwidenlwd -> "Pfwidenlwd" | Pfloatwrnsz -> "Pfloatwrnsz" | Pfloatuwrnsz -> "Pfloatuwrnsz" - | Pfloatudrnsz_i32 -> "Pfloatudrnsz_i32" | Pfloatudrnsz -> "Pfloatudrnsz" | Pfloatdrnsz -> "Pfloatdrnsz" - | Pfloatdrnsz_i32 -> "Pfloatdrnsz_i32" | Pfixedwrzz -> "Pfixedwrzz" | Pfixeduwrzz -> "Pfixeduwrzz" | Pfixeddrzz -> "Pfixeddrzz" @@ -500,9 +498,7 @@ let ab_inst_to_real = function | "Pfloatwrnsz" -> Floatwz | "Pfloatuwrnsz" -> Floatuwz | "Pfloatdrnsz" -> Floatdz - | "Pfloatdrnsz_i32" -> Floatdz | "Pfloatudrnsz" -> Floatudz - | "Pfloatudrnsz_i32" -> Floatudz | "Pfixedwrzz" -> Fixedwz | "Pfixeduwrzz" -> Fixeduwz | "Pfixeddrzz" -> Fixeddz diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8e8efefc..506faa1c 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -401,12 +401,8 @@ module Target (*: TARGET*) = fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs | Pfloatudrnsz(rd, rs) -> fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatudrnsz_i32(rd, rs) -> - fprintf oc " zxwd %a = %a\n # FIXME\n ;;\n floatud.rn.s %a = %a, 0\n" ireg rd ireg rs ireg rd ireg rd | Pfloatdrnsz(rd, rs) -> fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatdrnsz_i32(rd, rs) -> - fprintf oc " sxwd %a = %a\n # FIXME\n ;;\n floatd.rn.s %a = %a, 0\n" ireg rd ireg rs ireg rd ireg rd | Pfixedwrzz(rd, rs) -> fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs | Pfixeduwrzz(rd, rs) -> -- cgit From 7b0b080b118c097c84d5fb57a353cddf8c96b3ef Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 29 Apr 2019 14:44:24 +0200 Subject: rm unsupported int -> double signed/unsigned ops --- mppa_k1c/NeedOp.v | 2 +- mppa_k1c/Op.v | 12 ------------ mppa_k1c/PrintOp.ml | 2 -- mppa_k1c/ValueAOp.v | 2 -- 4 files changed, 1 insertion(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index abdcd94a..c10f5c56 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -112,7 +112,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) - | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => 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) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 093c8c17..baf17cc0 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -178,8 +178,6 @@ Inductive operation : Type := (*c Conversions between int and float: *) | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *) - | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *) - | Ofloatofintu (**r [rd = float64_of_unsigned_int(r1)] *) | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *) | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) @@ -485,8 +483,6 @@ Definition eval_operation | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 | Ointofsingle, v1::nil => Val.intofsingle v1 | Ointuofsingle, v1::nil => Val.intuofsingle v1 | Osingleofint, v1::nil => Val.singleofint v1 @@ -683,8 +679,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) | Ointuoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ofloatofintu => (Tint :: nil, Tfloat) | Ointofsingle => (Tsingle :: nil, Tint) | Ointuofsingle => (Tsingle :: nil, Tint) | Osingleofint => (Tint :: nil, Tsingle) @@ -919,9 +913,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* intoffloat, intuoffloat *) - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... - (* floatofint, floatofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... (* intofsingle, intuofsingle *) - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... @@ -1532,9 +1523,6 @@ Proof. exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. exists (Vint i); auto. - (* floatofint, floatofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. (* intofsingle, intuofsingle *) - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. exists (Vint i); auto. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 5ac00404..4b833014 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -141,8 +141,6 @@ 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 - | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 - | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%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 diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index fe8bddcf..064686cc 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -256,8 +256,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 | Ointuoffloat, v1::nil => intuoffloat v1 - | Ofloatofint, v1::nil => floatofint v1 - | Ofloatofintu, v1::nil => floatofintu v1 | Ointofsingle, v1::nil => intofsingle v1 | Ointuofsingle, v1::nil => intuofsingle v1 | Osingleofint, v1::nil => singleofint v1 -- cgit From 92da04b18cf8067624ae6d3c118de91fbb4b90b2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 29 Apr 2019 17:26:08 +0200 Subject: [BROKEN] Fixed the dumb scheduler, not yet properly integrated --- mppa_k1c/InstructionScheduler.ml | 4 +++- mppa_k1c/PostpassSchedulingOracle.ml | 5 +++-- 2 files changed, 6 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 1eba01d7..f9f99b1f 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -332,6 +332,8 @@ let dependency_check problem bundle index = let rec make_bundle problem resources bundle index = let resources_copy = Array.copy resources in + let nr_instructions = get_nr_instructions problem in + if (index >= nr_instructions) then (bundle, index+1) else let inst_usage = problem.instruction_usages.(index) in try match vector_less_equal inst_usage resources with | false -> raise InvalidBundle @@ -351,7 +353,7 @@ let rec make_bundles problem index : bundle list = let bundles_to_schedule problem bundles : solution = let nr_instructions = get_nr_instructions problem in - let schedule = Array.make nr_instructions (-1) in + let schedule = Array.make (nr_instructions+1) (nr_instructions+4) in let time = ref 0 in List.iter (fun bundle -> begin diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index decb5722..bd804fd6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -756,10 +756,11 @@ let print_bb oc bb = let do_schedule bb = let problem = build_problem bb - in let solution = validated_scheduler + (* in let solution = validated_scheduler (if !Clflags.option_fpostpass_ilp then cascaded_scheduler - else dumb_scheduler) problem + else dumb_scheduler) problem *) + in let solution = dumb_scheduler problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From c3003517a048d7469a314fc245118ed72e2158dd Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 29 Apr 2019 18:02:58 +0200 Subject: The scheduler selection works, but the argument is not optional yet (-fpostpass nameofscheduler) --- mppa_k1c/PostpassSchedulingOracle.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index bd804fd6..25bf99e0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -756,11 +756,17 @@ let print_bb oc bb = let do_schedule bb = let problem = build_problem bb + in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then + validated_scheduler cascaded_scheduler + else if !Clflags.option_fpostpass_sched = "list" then + validated_scheduler list_scheduler + else if !Clflags.option_fpostpass_sched = "dumb" then + dumb_scheduler else failwith "No scheduler provided") problem (* in let solution = validated_scheduler (if !Clflags.option_fpostpass_ilp then cascaded_scheduler else dumb_scheduler) problem *) - in let solution = dumb_scheduler problem + (* in let solution = dumb_scheduler problem *) in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From e570597b2f80a2a86b8672a40387dc63fd31b555 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Apr 2019 11:08:38 +0200 Subject: Setting fpostpass= option --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 25bf99e0..41a5454b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -761,7 +761,7 @@ let do_schedule bb = else if !Clflags.option_fpostpass_sched = "list" then validated_scheduler list_scheduler else if !Clflags.option_fpostpass_sched = "dumb" then - dumb_scheduler else failwith "No scheduler provided") problem + dumb_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem (* in let solution = validated_scheduler (if !Clflags.option_fpostpass_ilp then cascaded_scheduler -- cgit From 807b07dce1f41dc885d7671e8567ba112966ba7b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 15:48:11 +0200 Subject: begin load.xs --- mppa_k1c/Asm.v | 12 ++++++++++++ mppa_k1c/Asmblock.v | 2 ++ mppa_k1c/Asmblockdeps.v | 20 ++++++++++++++++++++ mppa_k1c/Asmvliw.v | 23 +++++++++++++++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 8 ++++---- mppa_k1c/PostpassSchedulingproof.v | 12 ++++++++++++ mppa_k1c/TargetPrinter.ml | 18 +++++++++++------- mppa_k1c/lib/Asmblockgenproof0.v | 1 + 8 files changed, 85 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d1ac8a67..0e217d36 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -42,6 +42,7 @@ Definition preg := preg. Inductive addressing : Type := | AOff (ofs: offset) | AReg (ro: ireg) + | ARegXS (ro: ireg) . (** Syntax *) @@ -444,6 +445,17 @@ Definition basic_to_instruction (b: basic) := | 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) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ed145f21..3aec4e11 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -268,6 +268,8 @@ Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ir 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_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_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset ge chunk rs rs m m s a ofs. Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2e83fb44..32a5fa04 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -75,6 +75,7 @@ Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := | OLoadRRO (n: load_name) (ofs: offset) | OLoadRRR (n: load_name) + | OLoadRRRXS (n: load_name) . Coercion OLoadRRO: load_name >-> Funclass. @@ -146,10 +147,17 @@ Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := | Some vl => Some (Val vl) end. +Definition exec_load_deps_regxs (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 + | 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 | _, _ => None end. @@ -355,6 +363,8 @@ Definition load_op_eq (o1 o2: load_op): ?? bool := match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_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 end. Lemma load_op_eq_correct o1 o2: @@ -363,6 +373,7 @@ Proof. destruct o1, o2; wlp_simplify; try discriminate. - congruence. - congruence. + - congruence. Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. @@ -612,6 +623,7 @@ Definition trans_basic (b: basic) : inst := | 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))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); @@ -828,6 +840,13 @@ Proof. 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; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + (* Store *) - destruct i. (* Store Offset *) @@ -1408,6 +1427,7 @@ 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 end. Definition string_of_store_name (n: store_name) : pstring := diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index cf827818..d7311272 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -270,6 +270,7 @@ 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) . Coercion PLoadRRO: load_name >-> Funclass. @@ -1123,6 +1124,27 @@ Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) | Some v => Next (rsw#d <- v) mw end. +Definition scale_of_chunk (chunk: memory_chunk) := + Vint (Int.repr + (match chunk with + | Mint8signed => 0 + | Mint8unsigned => 0 + | Mint16signed => 1 + | Mint16unsigned => 1 + | Mint32 => 2 + | Mint64 => 3 + | Mfloat32 => 2 + | Mfloat64 => 3 + | Many32 => 2 + | Many64 => 3 + end)). + +Definition parexec_load_regxs (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 + | Some v => Next (rsw#d <- v) mw + end. + Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := match (eval_offset ofs) with | OK ptr => match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with @@ -1172,6 +1194,7 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | 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 | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f931b64b..ef5e325a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -216,10 +216,10 @@ let arith_rec i = | 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} - | PLoadRRR (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} + | 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} + | 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} 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)) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index bc90dd4c..3f3cb19c 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -117,6 +117,17 @@ Proof. - 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_store_offset_pc_var: forall ge t rs m rd ra ofs rs' m' v, exec_store_offset ge t rs m rd ra ofs = Next rs' m' -> @@ -155,6 +166,7 @@ Proof. - 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. - destruct i. + exploreInst; apply exec_store_offset_pc_var; auto. + exploreInst; apply exec_store_reg_pc_var; auto. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 506faa1c..47927364 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -166,7 +166,11 @@ module Target (*: TARGET*) = let addressing oc = function | AOff ofs -> offset oc ofs - | AReg ro -> ireg oc ro + | AReg ro | ARegXS ro -> ireg oc ro + + let xscale oc = function + | ARegXS _ -> fprintf oc ".xs" + | _ -> () let icond_name = let open Asmvliw in function | ITne | ITneu -> "ne" @@ -342,17 +346,17 @@ module Target (*: TARGET*) = (* Load/Store instructions *) | Plb(rd, ra, adr) -> - fprintf oc " lbs %a = %a[%a]\n" ireg rd addressing adr ireg ra + 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]\n" ireg rd addressing adr ireg ra + 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]\n" ireg rd addressing adr ireg ra + 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]\n" ireg rd addressing adr ireg ra + 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]\n" ireg rd addressing adr ireg ra + 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]\n" ireg rd addressing adr ireg ra + fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra | Psb(rd, ra, adr) -> fprintf oc " sb %a[%a] = %a\n" addressing adr ireg ra ireg rd diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index eb336edc..ab0d2964 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -946,6 +946,7 @@ Proof. all: try (inv H; Simpl). 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ge 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 ge 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. - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. -- cgit From 26a7a6598a80c29a139c533419b38be63c88cd76 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 16:24:32 +0200 Subject: indexed2XS begin --- mppa_k1c/Asmblockgen.v | 1 + mppa_k1c/Asmblockgenproof1.v | 4 ++++ mppa_k1c/Op.v | 8 +++++--- 3 files changed, 10 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 6cd31468..c2a0a315 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -888,6 +888,7 @@ Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := match addr with + | Aindexed2XS _ => Error (msg "transl_load Aindexed2XS") | Aindexed2 => transl_load_rrr chunk addr args dst k | _ => transl_load_rro chunk addr args dst k end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 40f9f08b..0cb2d83d 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2168,6 +2168,7 @@ Lemma transl_load_memory_access_ok: Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. + - (* Indexed2XS*) monadInv TR. - 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 @@ -2210,6 +2211,7 @@ Lemma transl_load_correct: /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR EV LOAD. destruct addr. + 1: (* Aindexed2XS *) discriminate. 2-4: exploit transl_load_memory_access_ok; eauto; try discriminate; intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; eapply transl_load_access_correct; eauto with asmgen. @@ -2293,6 +2295,7 @@ Lemma transl_store_memory_access_ok: Proof. intros until m'. intros ? TR ? ?. unfold transl_store in TR. destruct addr; try contradiction. + - (* Aindex2XS *) discriminate. - monadInv TR. destruct chunk. all: ArgsInv; eexists; eexists; eexists; split; try split; [ repeat (destruct args; try discriminate); eassumption @@ -2362,6 +2365,7 @@ Lemma transl_store_correct: /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. destruct addr. + 1: (* AIndexed2XS *) discriminate. 2-4: exploit transl_store_memory_access_ok; eauto; try discriminate; intro A; destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); rewrite D in STORE; clear D; diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index baf17cc0..22fce4c9 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -207,7 +207,8 @@ Inductive operation : Type := addressing. *) Inductive addressing: Type := - | Aindexed2: addressing (**r Address is [r1 + r2] *) + | Aindexed2XS (scale : Z) : addressing (**r Address is [r1 + r2 << scale] *) + | Aindexed2 : addressing (**r Address is [r1 + r2] *) | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) @@ -230,7 +231,7 @@ Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. Proof. - generalize ident_eq Ptrofs.eq_dec; intros. + generalize ident_eq Ptrofs.eq_dec Z.eq_dec; intros. decide equality. Defined. @@ -705,6 +706,7 @@ Definition type_of_operation (op: operation) : list typ * typ := Definition type_of_addressing (addr: addressing) : list typ := match addr with + | Aindexed2XS _ => Tptr :: Tptr :: Tptr :: nil | Aindexed2 => Tptr :: Tptr :: nil | Aindexed _ => Tptr :: nil | Aglobal _ _ => nil @@ -1117,7 +1119,7 @@ Qed. Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := match addr with - | Aindexed2 => None + | Aindexed2 | Aindexed2XS _ => None | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) -- cgit From 667c260620b545c04355dd030fc4430790a3a055 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 17:04:34 +0200 Subject: translate load.xs --- mppa_k1c/Asmblockgen.v | 20 +++++++++++++++++++- mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof1.v | 7 ++++++- mppa_k1c/Asmvliw.v | 8 ++++---- 4 files changed, 30 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c2a0a315..7c8a08f6 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -846,6 +846,19 @@ Definition transl_memory_access2 | _, _ => Error (msg "Asmblockgen.transl_memory_access2") end. +Definition transl_memory_access2XS + (chunk: memory_chunk) + (mk_instr: ireg -> ireg -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := + match addr, args with + | (Aindexed2XS scale), (a1 :: a2 :: nil) => + assertion (Z.eqb (zscale_of_chunk chunk) scale); + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (mk_instr rs1 rs2 ::i k) + | _, _ => Error (msg "Asmblockgen.transl_memory_access2XS") + end. + Definition transl_memory_access (mk_instr: ireg -> offset -> basic) (addr: addressing) (args: list mreg) (k: bcode) : res bcode := @@ -885,10 +898,15 @@ Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) do r <- ireg_of dst; transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k. +Definition transl_load_rrrXS (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + do r <- ireg_of dst; + transl_memory_access2XS chunk (PLoadRRR (chunk2load chunk) r) addr args k. + Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := match addr with - | Aindexed2XS _ => Error (msg "transl_load Aindexed2XS") + | Aindexed2XS _ => transl_load_rrrXS chunk addr args dst k | Aindexed2 => transl_load_rrr chunk addr args dst k | _ => transl_load_rro chunk addr args dst k end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c6c88681..e710b5a4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -521,7 +521,7 @@ Proof. 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; 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; exploreInst; try discriminate. Qed. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 0cb2d83d..5e44b7a5 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2168,7 +2168,12 @@ Lemma transl_load_memory_access_ok: Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - - (* Indexed2XS*) monadInv TR. + - monadInv TR. + destruct chunk; + simpl in EQ0; + ArgsInv; + try discriminate; + econstructor; (esplit; eauto). - 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 diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index d7311272..7a5adf5e 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1124,9 +1124,8 @@ Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) | Some v => Next (rsw#d <- v) mw end. -Definition scale_of_chunk (chunk: memory_chunk) := - Vint (Int.repr - (match chunk with +Definition zscale_of_chunk (chunk: memory_chunk) := + match chunk with | Mint8signed => 0 | Mint8unsigned => 0 | Mint16signed => 1 @@ -1137,7 +1136,8 @@ Definition scale_of_chunk (chunk: memory_chunk) := | Mfloat64 => 3 | Many32 => 2 | Many64 => 3 - end)). + end. +Definition scale_of_chunk chunk := Vint (Int.repr (zscale_of_chunk chunk)). Definition parexec_load_regxs (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 -- cgit From 6fe707cbbb2e579992a428e4bba122a74df2d493 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 18:56:22 +0200 Subject: advancing (but broken) --- mppa_k1c/Op.v | 4 ++++ mppa_k1c/ValueAOp.v | 1 + 2 files changed, 5 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 22fce4c9..b9d9cc43 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -514,6 +514,7 @@ Definition eval_addressing (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with + | Aindexed2XS scale, v1 :: v2 :: nil => Some (Val.addl v1 (Val.shll v2 (Vint (Int.repr scale)))) | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) @@ -1663,6 +1664,9 @@ Lemma eval_addressing_inj: exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. Proof. intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. + - apply Val.addl_inject; trivial. + destruct v0; destruct v'0; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial; inv H3. + apply Val.inject_long. - apply Val.addl_inject; auto. - apply Val.offset_ptr_inject; auto. - apply H; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 064686cc..643cca0c 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -37,6 +37,7 @@ Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := match addr, vl with | Aindexed n, v1::nil => offset_ptr v1 n | Aindexed2, v1::v2::nil => addl v1 v2 + | Aindexed2XS scale, v1::v2::nil => addl v1 (shll v2 (I (Int.repr scale))) | Aglobal s ofs, nil => Ptr (Gl s ofs) | Ainstack ofs, nil => Ptr (Stk ofs) | _, _ => Vbot -- cgit From aea7e3d6a6b09727724edfa11358111c9a05cd1b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 18:59:57 +0200 Subject: pass one proof --- mppa_k1c/Asmblockgenproof1.v | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5e44b7a5..ed049539 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2156,7 +2156,7 @@ Qed. Lemma transl_load_memory_access_ok: forall addr chunk args dst k c rs a v m, - addr <> Aindexed2 -> + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> transl_load 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 -> @@ -2168,12 +2168,7 @@ Lemma transl_load_memory_access_ok: Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - - monadInv TR. - destruct chunk; - simpl in EQ0; - ArgsInv; - try discriminate; - econstructor; (esplit; eauto). + - admit. - 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 -- cgit From 98be0205d9d29378fb272a9f424144651bd8afec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 19:44:11 +0200 Subject: ça avance MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockgen.v | 14 ++++---- mppa_k1c/Asmblockgenproof1.v | 83 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 85 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 7c8a08f6..a74aa9f6 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -849,14 +849,14 @@ Definition transl_memory_access2 Definition transl_memory_access2XS (chunk: memory_chunk) (mk_instr: ireg -> ireg -> basic) - (addr: addressing) (args: list mreg) (k: bcode) : res bcode := - match addr, args with - | (Aindexed2XS scale), (a1 :: a2 :: nil) => + scale (args: list mreg) (k: bcode) : res bcode := + match args with + | (a1 :: a2 :: nil) => assertion (Z.eqb (zscale_of_chunk chunk) scale); do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (mk_instr rs1 rs2 ::i k) - | _, _ => Error (msg "Asmblockgen.transl_memory_access2XS") + | _ => Error (msg "Asmblockgen.transl_memory_access2XS") end. Definition transl_memory_access @@ -898,15 +898,15 @@ Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) do r <- ireg_of dst; transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k. -Definition transl_load_rrrXS (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRR (chunk2load chunk) r) addr args k. + transl_memory_access2XS chunk (PLoadRRR (chunk2load chunk) r) scale args k. Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := match addr with - | Aindexed2XS _ => transl_load_rrrXS chunk addr args dst k + | 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 end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ed049539..c9d72c4d 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2110,6 +2110,26 @@ Proof. inv EV. repeat eexists. eassumption. econstructor; eauto. Qed. +Lemma transl_memory_access2XS_correct: + forall chunk mk_instr (scale : Z) args k c (rs: regset) m v, + 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 -> + exists base ro mro mr1 rs', + args = mr1 :: mro :: nil + /\ ireg_of mro = OK ro + /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m + /\ Val.addl rs'#base (Val.shll rs'#ro (Vint (Int.repr scale))) = v + /\ (forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r) + /\ scale = (zscale_of_chunk chunk). +Proof. + intros until v; intros TR EV. + unfold transl_memory_access2XS in TR; ArgsInv. + inv EV. repeat eexists. eassumption. econstructor; eauto. + symmetry. + apply Z.eqb_eq. + assumption. +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', args = mr1 :: mro :: nil -> @@ -2133,6 +2153,32 @@ Proof. 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', + 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) -> + 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' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; 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; intros; Simpl. auto. +Qed. + Lemma transl_load_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, @@ -2168,7 +2214,6 @@ Lemma transl_load_memory_access_ok: Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - - admit. - 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 @@ -2200,6 +2245,27 @@ Proof. | 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 -> + 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, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr (Aindexed2XS scale) 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. +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 := (PLoadRRR _ x)); simpl; rewrite Heqb; reflexivity + | 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 -> @@ -2211,12 +2277,19 @@ Lemma transl_load_correct: /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. Proof. intros until v; intros TR EV LOAD. destruct addr. - 1: (* Aindexed2XS *) discriminate. - 2-4: exploit transl_load_memory_access_ok; eauto; try discriminate; - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access2XS_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - exploit transl_load_memory_access2_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. Qed. Lemma transl_store_access2_correct: -- cgit From cbe3f094b32077ce8d8569556d4ebc6341b09dd9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 21:54:11 +0200 Subject: it compiles --- mppa_k1c/Asm.v | 9 ++++ mppa_k1c/Asmblock.v | 2 + mppa_k1c/Asmblockdeps.v | 20 ++++++++ mppa_k1c/Asmblockgen.v | 36 +++++++------ mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof1.v | 99 ++++++++++++++++++++++++++++++++---- mppa_k1c/Asmvliw.v | 14 ++--- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- mppa_k1c/PostpassSchedulingproof.v | 12 +++++ mppa_k1c/lib/Asmblockgenproof0.v | 1 + 10 files changed, 164 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 0e217d36..d73d00c7 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -475,6 +475,15 @@ Definition basic_to_instruction (b: basic) := | 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) + end. Section RELSEM. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 3aec4e11..1988813f 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -274,6 +274,8 @@ Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: i Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. +Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_regxs chunk rs rs m m 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. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 32a5fa04..f6573838 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -83,6 +83,7 @@ Coercion OLoadRRO: load_name >-> Funclass. Inductive store_op := | OStoreRRO (n: store_name) (ofs: offset) | OStoreRRR (n: store_name) + | OStoreRRRXS (n: store_name) . Coercion OStoreRRO: store_name >-> Funclass. @@ -177,10 +178,17 @@ Definition exec_store_deps_reg (chunk: memory_chunk) (m: mem) (vs va vo: val) := | Some m' => Some (Memstate m') end. +Definition exec_store_deps_regxs (chunk: memory_chunk) (m: mem) (vs va vo: val) := + match Mem.storev chunk m (Val.addl va (Val.shll vo (scale_of_chunk chunk))) vs with + | None => None + | Some m' => Some (Memstate m') + end. + Definition store_eval (so: store_op) (l: list value) := match so, l with | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps_offset (store_chunk n) m vs va ofs | OStoreRRR n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_reg (store_chunk n) m vs va vo + | OStoreRRRXS n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_regxs (store_chunk n) m vs va vo | _, _ => None end. @@ -385,6 +393,8 @@ Definition store_op_eq (o1 o2: store_op): ?? bool := match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) | _ => RET false end | OStoreRRR n1 => match o2 with OStoreRRR n2 => phys_eq n1 n2 | _ => RET false end + | OStoreRRRXS n1 => + match o2 with OStoreRRRXS n2 => phys_eq n1 n2 | _ => RET false end end. Lemma store_op_eq_correct o1 o2: @@ -393,6 +403,7 @@ Proof. destruct o1, o2; wlp_simplify; try discriminate. - congruence. - congruence. + - congruence. Qed. Hint Resolve store_op_eq_correct: wlp. Opaque store_op_eq_correct. @@ -626,6 +637,7 @@ Definition trans_basic (b: basic) : inst := | PLoadRRRXS n d a ro => [(#d, Op (Load (OLoadRRRXS n)) (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))] | 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))] | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); @@ -864,6 +876,13 @@ Proof. eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + (* Store Reg XS *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_regxs; simpl; unfold exec_store_deps_regxs; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. + (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. @@ -1446,6 +1465,7 @@ Definition string_of_store (op: store_op) : pstring := match op with | OStoreRRO n _ => string_of_store_name n | OStoreRRR n => string_of_store_name n + | OStoreRRRXS n => string_of_store_name n end. Definition string_of_control (op: control_op) : pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index a74aa9f6..ea99c098 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -807,31 +807,31 @@ 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 (Plw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k) + | 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) | _, _ => Error (msg "Asmblockgen.loadind") end. Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := match ty, preg_of src with - | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k) + | Tint, IR rd => OK (indexed_memory_access (PStoreRRO Psw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PStoreRRO Psd rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PStoreRRO Pfss rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PStoreRRO Pfsd rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PStoreRRO Psw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PStoreRRO Psd_a rd) base ofs ::i k) | _, _ => Error (msg "Asmblockgen.storeind") end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := - indexed_memory_access (Pld dst) base ofs. + indexed_memory_access (PLoadRRO Pld dst) base ofs. Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := - indexed_memory_access (Psd src) base ofs. + indexed_memory_access (PStoreRRO Psd src) base ofs. (** Translation of memory accesses: loads, and stores. *) @@ -901,7 +901,7 @@ Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRR (chunk2load chunk) r) scale args k. + transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. Definition transl_load (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := @@ -933,10 +933,16 @@ Definition transl_store_rrr (chunk: memory_chunk) (addr: addressing) do r <- ireg_of src; transl_memory_access2 (PStoreRRR (chunk2store chunk) r) addr args k. +Definition transl_store_rrrxs (chunk: memory_chunk) (scale: Z) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + do r <- ireg_of src; + transl_memory_access2XS chunk (PStoreRRRXS (chunk2store chunk) r) scale args k. + Definition transl_store (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg) (k: bcode) : res bcode := match addr with | Aindexed2 => transl_store_rrr chunk addr args src k + | Aindexed2XS scale => transl_store_rrrxs chunk scale args src k | _ => transl_store_rro chunk addr args src k end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e710b5a4..0233a3dc 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -523,7 +523,7 @@ Proof. - 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; 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: diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c9d72c4d..82f3b0fc 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2254,15 +2254,15 @@ Lemma transl_load_memory_access2XS_ok: args = mr0 :: mro :: nil /\ preg_of dst = IR rd /\ preg_of mro = IR ro - /\ transl_memory_access2XS chunk mk_instr (Aindexed2XS scale) args k = OK c + /\ 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_reg chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs 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 := (PLoadRRR _ x)); simpl; rewrite Heqb; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto | eauto]. Qed. @@ -2316,6 +2316,33 @@ Proof. auto. Qed. +Lemma transl_store_access2XS_correct: + forall chunk (mk_instr: ireg -> ireg -> basic) scale args k c r1 (rs: regset) m v mr1 mro ro m', + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_regxs chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. 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_store_regxs. unfold parexec_store_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + Lemma transl_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', (forall base ofs rs, @@ -2355,7 +2382,7 @@ Qed. Lemma transl_store_memory_access_ok: forall addr chunk args src k c rs a m m', - addr <> Aindexed2 -> + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> transl_store chunk addr args src k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.storev chunk m a (rs (preg_of src)) = Some m' -> @@ -2368,7 +2395,6 @@ Lemma transl_store_memory_access_ok: Proof. intros until m'. intros ? TR ? ?. unfold transl_store in TR. destruct addr; try contradiction. - - (* Aindex2XS *) discriminate. - monadInv TR. destruct chunk. all: ArgsInv; eexists; eexists; eexists; split; try split; [ repeat (destruct args; try discriminate); eassumption @@ -2403,6 +2429,20 @@ Proof. erewrite <- Mem.store_signed_unsigned_16. reflexivity. Qed. +Remark exec_store_regxs_8_sign rs m x base ofs: + exec_store_regxs Mint8unsigned rs m x base ofs = exec_store_regxs Mint8signed rs m x base ofs. +Proof. + unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_regxs_16_sign rs m x base ofs: + exec_store_regxs Mint16unsigned rs m x base ofs = exec_store_regxs Mint16signed rs m x base ofs. +Proof. + unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + Lemma transl_store_memory_access2_ok: forall addr chunk args src k c rs a m m', addr = Aindexed2 -> @@ -2428,6 +2468,30 @@ Proof. - simpl. intros. eapply exec_store_reg_16_sign. Qed. +Lemma transl_store_memory_access2XS_ok: + forall scale chunk args src k c rs a m m', + transl_store chunk (Aindexed2XS scale) args src k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr mr0 mro ro, + args = mr0 :: mro :: nil + /\ preg_of mro = IR ro + /\ preg_of src = IR rr + /\ 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_store_regxs chunk' rs m rr base ro) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros TR ? ?. + unfold transl_store in TR. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ ArgsInv; reflexivity + | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRRXS _ x)); simpl; rewrite Heqb; eauto + | eauto ]. + - simpl. intros. eapply exec_store_regxs_8_sign. + - simpl. intros. eapply exec_store_regxs_16_sign. +Qed. + Lemma transl_store_correct: forall chunk addr args src k c (rs: regset) m a m', transl_store chunk addr args src k = OK c -> @@ -2438,15 +2502,30 @@ Lemma transl_store_correct: /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. intros until m'; intros TR EV STORE. destruct addr. - 1: (* AIndexed2XS *) discriminate. - 2-4: exploit transl_store_memory_access_ok; eauto; try discriminate; intro A; + - exploit transl_store_memory_access2XS_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). + eapply transl_store_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. + destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. + - exploit transl_store_memory_access2_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). + eapply transl_store_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. + destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); rewrite D in STORE; clear D; eapply transl_store_access_correct; eauto with asmgen; try congruence; destruct rr; try discriminate; destruct src; try discriminate. - - exploit transl_store_memory_access2_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). - eapply transl_store_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. - destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. Qed. Lemma make_epilogue_correct: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 7a5adf5e..629d1449 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -273,9 +273,6 @@ Inductive ld_instruction : Type := | PLoadRRRXS (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) . -Coercion PLoadRRO: load_name >-> Funclass. -Coercion PLoadRRR: load_name >-> Funclass. - (** Stores **) Inductive store_name : Type := | Psb (**r store byte *) @@ -291,11 +288,9 @@ Inductive store_name : Type := Inductive st_instruction : Type := | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) + | PStoreRRRXS(i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) . -Coercion PStoreRRO: store_name >-> Funclass. -Coercion PStoreRRR: store_name >-> Funclass. - (** Arithmetic instructions **) Inductive arith_name_r : Type := | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) @@ -1160,6 +1155,12 @@ Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem | Some m' => Next rsw m' end. +Definition parexec_store_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := + match Mem.storev chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end. + Definition load_chunk n := match n with | Plb => Mint8signed @@ -1198,6 +1199,7 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro + | PStoreRRRXS n s a ro => parexec_store_regxs (store_chunk n) rsr rsw mr mw s a ro | Pallocframe sz pos => let (mw, stk) := Mem.alloc mr 0 sz in diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index ef5e325a..e6643736 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -224,7 +224,7 @@ let load_rec i = match i with 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} - | PStoreRRR (i, rs1, rs2, rs3) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None + | 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} let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 3f3cb19c..43c8acb8 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -151,6 +151,17 @@ Proof. - 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' -> @@ -170,6 +181,7 @@ Proof. - 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. - 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. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index ab0d2964..0a83a903 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -949,6 +949,7 @@ Proof. 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 ge 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. - 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. -- cgit From 57ddece94f4c4b44e8e3127c6f5f72aaa5962250 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 22:20:35 +0200 Subject: does not yet work, arity mismatch --- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 1 + mppa_k1c/Asmblockgenproof1.v | 1 + mppa_k1c/Asmvliw.v | 16 +--------------- mppa_k1c/SelectOp.vp | 6 ++++++ mppa_k1c/SelectOpproof.v | 5 +++++ 6 files changed, 15 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index f6573838..1ee5002c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -13,6 +13,7 @@ Require Import ImpDep. Require Import Axioms. Require Import Parallelizability. Require Import Asmvliw Permutation. +Require Import Chunks. Open Scope impure. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ea99c098..ca7094da 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -22,6 +22,7 @@ Require Import Coqlib Errors. Require Import AST Integers Floats Memdata. Require Import Op Locations Machblock Asmblock. Require ExtValues. +Require Import Chunks. Local Open Scope string_scope. Local Open Scope error_monad_scope. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 82f3b0fc..b265f221 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -19,6 +19,7 @@ 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 Chunks. (** Decomposition of integer constants. *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 629d1449..e460727c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -35,6 +35,7 @@ Require Stacklayout. Require Import Conventions. Require Import Errors. Require Import Sorting.Permutation. +Require Import Chunks. (** * Abstract syntax *) @@ -1119,21 +1120,6 @@ Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) | Some v => Next (rsw#d <- v) mw end. -Definition zscale_of_chunk (chunk: memory_chunk) := - match chunk with - | Mint8signed => 0 - | Mint8unsigned => 0 - | Mint16signed => 1 - | Mint16unsigned => 1 - | Mint32 => 2 - | Mint64 => 3 - | Mfloat32 => 2 - | Mfloat64 => 3 - | Many32 => 2 - | Many64 => 3 - end. -Definition scale_of_chunk chunk := Vint (Int.repr (zscale_of_chunk chunk)). - Definition parexec_load_regxs (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 diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 25f09e2e..28b91728 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -53,6 +53,7 @@ Require Import CminorSel. Require Import OpHelpers. Require Import ExtValues. Require Import DecBoolOps. +Require Import Chunks. Local Open Scope cminorsel_scope. @@ -584,6 +585,11 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code 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) => + 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) | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) | _ => (Aindexed Ptrofs.zero, e:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 6fa93fd8..a92ed572 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1265,6 +1265,11 @@ 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 (Z.eq_dec _ _). + + exists (v1 :: v2 :: nil); split. repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. + + exists (v1 :: v0 :: nil); split. repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. 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. -- cgit From 14d2059195b5c66cd7e77184b0e76e95147aaaa9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 22:33:11 +0200 Subject: load xs / store xs seem to work --- mppa_k1c/Op.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index b9d9cc43..5e80589b 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -705,9 +705,10 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) end. +(* FIXME: two Tptr ?! *) Definition type_of_addressing (addr: addressing) : list typ := match addr with - | Aindexed2XS _ => Tptr :: Tptr :: Tptr :: nil + | Aindexed2XS _ => Tptr :: Tptr :: nil | Aindexed2 => Tptr :: Tptr :: nil | Aindexed _ => Tptr :: nil | Aglobal _ _ => nil -- cgit From 49f970ff21e05135dba6b1b32d52c77564cdcee3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 May 2019 22:49:37 +0200 Subject: fix targetprinter bug for .xs --- mppa_k1c/TargetPrinter.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 47927364..62b02f58 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -359,13 +359,13 @@ module Target (*: TARGET*) = fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra | Psb(rd, ra, adr) -> - fprintf oc " sb %a[%a] = %a\n" addressing adr ireg ra ireg rd + fprintf oc " sb%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd | Psh(rd, ra, adr) -> - fprintf oc " sh %a[%a] = %a\n" addressing adr ireg ra ireg rd + fprintf oc " sh%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd | Psw(rd, ra, adr) | Psw_a(rd, ra, adr) | Pfss(rd, ra, adr) -> - fprintf oc " sw %a[%a] = %a\n" addressing adr ireg ra ireg rd + fprintf oc " sw%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd | Psd(rd, ra, adr) | Psd_a(rd, ra, adr) | Pfsd(rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " sd %a[%a] = %a\n" addressing adr ireg ra ireg rd + fprintf oc " sd%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd (* Arith R instructions *) -- cgit From 053cfa54205575ceb984f5922f51f4fce5980604 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 06:57:46 +0200 Subject: forgot Chunks.v --- mppa_k1c/Chunks.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 mppa_k1c/Chunks.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Chunks.v b/mppa_k1c/Chunks.v new file mode 100644 index 00000000..833f8116 --- /dev/null +++ b/mppa_k1c/Chunks.v @@ -0,0 +1,20 @@ +Require Import AST. +Require Import Values. +Require Import Integers. + +Local Open Scope Z_scope. + +Definition zscale_of_chunk (chunk: memory_chunk) := + match chunk with + | Mint8signed => 0 + | Mint8unsigned => 0 + | Mint16signed => 1 + | Mint16unsigned => 1 + | Mint32 => 2 + | Mint64 => 3 + | Mfloat32 => 2 + | Mfloat64 => 3 + | Many32 => 2 + | Many64 => 3 + end. +Definition scale_of_chunk chunk := Vint (Int.repr (zscale_of_chunk chunk)). -- cgit From 9f256a4ad30c93749e6c1192a84f996feac3b023 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 09:32:49 +0200 Subject: command line options (still incomplete) --- mppa_k1c/SelectOp.vp | 16 +++++++++++----- mppa_k1c/SelectOpproof.v | 19 +++++++++++++------ 2 files changed, 24 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 28b91728..6adcebe5 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -54,6 +54,7 @@ Require Import OpHelpers. Require Import ExtValues. Require Import DecBoolOps. Require Import Chunks. +Require Compopts. Local Open Scope cminorsel_scope. @@ -582,14 +583,19 @@ Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) + | Eop (Oaddrsymbol id ofs) Enil => + (if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp 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) => - 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) + (if Compopts.optim_fxsaddr 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 Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) | _ => (Aindexed Ptrofs.zero, e:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index a92ed572..9e2eec8b 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1256,7 +1256,7 @@ Theorem eval_addressing: Proof. intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - exists (@nil val); split. eauto with evalexpr. simpl. auto. - - destruct (Archi.pic_code tt). + - destruct (orb _ _). + exists (Vptr b ofs0 :: nil); split. constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. + exists (@nil val); split. constructor. simpl; auto. @@ -1265,11 +1265,18 @@ 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 (Z.eq_dec _ _). - + exists (v1 :: v2 :: nil); split. repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. - + exists (v1 :: v0 :: nil); split. repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. - simpl. congruence. + - destruct (Compopts.optim_fxsaddr tt). + + destruct (Z.eq_dec _ _). + * exists (v1 :: v2 :: nil); split. + repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. + * exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. + + exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. 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. -- cgit From 98206d8c97cf9ecdff8d892ecafb9a9fa8455f74 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 09:44:56 +0200 Subject: fix slow globals etc. --- mppa_k1c/ConstpropOp.vp | 2 +- mppa_k1c/ConstpropOpproof.v | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp index aab2424d..b5128357 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 Archi.pic_code tt + if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp 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/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v index b6c73281..ae11a220 100644 --- a/mppa_k1c/ConstpropOpproof.v +++ b/mppa_k1c/ConstpropOpproof.v @@ -730,7 +730,7 @@ Proof. intros until res. unfold addr_strength_reduction. destruct (addr_strength_reduction_match addr args vl); simpl; intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- destruct (Archi.pic_code tt). +- destruct (orb _ _). + exists (Val.offset_ptr e#r1 n); auto. + simpl. rewrite Genv.shift_symbol_address. econstructor; split; eauto. inv H0; simpl; auto. -- cgit From c56f9a47fe1837b7afb73c2c24aed9228bc0db08 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 10:21:09 +0200 Subject: allow disabling + xx global symbols --- mppa_k1c/SelectLong.vp | 5 ++++- mppa_k1c/SelectLongproof.v | 8 +++++--- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 3b9e5bf9..717b0120 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -70,7 +70,10 @@ 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 => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddrsymbol s m) Enil => + (if Compopts.optim_fglobaladdroffset 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 (Oaddlimm n) (e ::: Enil) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index cf8eed2b..3b724c01 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -127,9 +127,11 @@ 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. -- 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. +- destruct (Compopts.optim_fglobaladdroffset _). + + 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. + + TrivialExists. repeat econstructor. simpl. trivial. - econstructor; split. EvalOp. simpl; eauto. destruct sp; simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. -- cgit From df9f42773b48270e77d1760719b1d8399062c2ea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 20:23:56 +0200 Subject: seems to work --- mppa_k1c/Peephole.v | 15 +++++++++++++++ mppa_k1c/PostpassScheduling.v | 6 ++++-- 2 files changed, 19 insertions(+), 2 deletions(-) create mode 100644 mppa_k1c/Peephole.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v new file mode 100644 index 00000000..56e547e5 --- /dev/null +++ b/mppa_k1c/Peephole.v @@ -0,0 +1,15 @@ +Require Import Asmvliw. + +Definition optimize_body (insns : list basic) := insns. + +Program Definition optimize_bblock (bb : bblock) := + let optimized := optimize_body (body bb) in + let wf_ok := wf_bblockb optimized (exit bb) in + {| header := header bb; + body := if wf_ok then optimized else (body bb); + exit := exit bb |}. +Next Obligation. + destruct (wf_bblockb (optimize_body (body bb))) eqn:Rwf. + - rewrite Rwf. simpl. trivial. + - exact (correct bb). +Qed. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index ab4bc9c9..ecd40f5c 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -13,6 +13,7 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. Require Import Asmblockdeps Asmblockgenproof0. +Require Peephole. Local Open Scope error_monad_scope. @@ -347,8 +348,9 @@ Fixpoint verify_par (lbb: list bblock) := end. Definition verified_schedule_nob (bb : bblock) : res (list bblock) := - let bb' := no_header bb in - let lbb := do_schedule bb' in + let bb' := no_header bb in + let bb'' := Peephole.optimize_bblock bb' in + let lbb := do_schedule bb'' in do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; -- cgit From ec84544fb9f842caf98ca61669a8fb3024504ae2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 21:14:48 +0200 Subject: found peephole --- mppa_k1c/Peephole.v | 22 +++++++++++++++++++++- mppa_k1c/extractionMachdep.v | 3 +++ 2 files changed, 24 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 56e547e5..b7931aca 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -1,6 +1,26 @@ +Require Import Coqlib. Require Import Asmvliw. +Require Import Values. +Require Import Integers. -Definition optimize_body (insns : list basic) := insns. +Parameter print_found_store : forall A : Type, Z -> A -> A. + +Fixpoint optimize_body (insns : list basic) : list basic := + match insns with + | nil => nil + | h0 :: t0 => + match t0 with + | h1 :: t1 => + match h0, h1 with + | (PStoreRRO Psd_a rs0 ra0 (Ofsimm ofs0)), + (PStoreRRO Psd_a rs1 ra1 (Ofsimm ofs1)) => + let h0' := print_found_store basic (Ptrofs.signed ofs0) h0 in + h0' :: (optimize_body t0) + | _, _ => h0 :: (optimize_body t0) + end + | nil => h0 :: nil + end + end. Program Definition optimize_bblock (bb : bblock) := let optimized := optimize_body (body bb) in diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v index e70f51de..fdecd2a3 100644 --- a/mppa_k1c/extractionMachdep.v +++ b/mppa_k1c/extractionMachdep.v @@ -22,6 +22,9 @@ Require Archi Asm. Extract Constant Archi.ptr64 => " Configuration.model = ""64"" ". Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) +Extract Constant Peephole.print_found_store => +"fun offset x -> Printf.printf ""found offset = %ld\n"" (Camlcoq.camlint_of_coqint offset); x". + (* Asm *) (* Extract Constant Asm.low_half => "fun _ _ _ -> assert false". -- cgit From 56ab9fea6dc937dac56e883a64f06cae3c931551 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 21:20:14 +0200 Subject: detect consecutive ones --- mppa_k1c/Peephole.v | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index b7931aca..47e04aec 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -14,8 +14,12 @@ Fixpoint optimize_body (insns : list basic) : list basic := match h0, h1 with | (PStoreRRO Psd_a rs0 ra0 (Ofsimm ofs0)), (PStoreRRO Psd_a rs1 ra1 (Ofsimm ofs1)) => - let h0' := print_found_store basic (Ptrofs.signed ofs0) h0 in - h0' :: (optimize_body t0) + let zofs0 := Ptrofs.signed ofs0 in + let zofs1 := Ptrofs.signed ofs1 in + if zofs1 =? zofs0 + 8 + then let h0' := print_found_store basic zofs0 h0 in + h0' :: (optimize_body t0) + else h0 :: (optimize_body t0) | _, _ => h0 :: (optimize_body t0) end | nil => h0 :: nil -- cgit From 5d09dd8f3194ecc90137178d6b5d18b9ad31aabf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 2 May 2019 21:58:47 +0200 Subject: find consecutive writes --- mppa_k1c/Asmvliw.v | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ mppa_k1c/Peephole.v | 38 ++++++++++++++++++++++++++++++++------ 2 files changed, 83 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e460727c..0cbe27e1 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -66,12 +66,63 @@ Inductive gpreg: Type := Definition ireg := gpreg. Definition freg := gpreg. +Lemma gpreg_eq: forall (x y: gpreg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. Proof. decide equality. Defined. Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. Proof. decide equality. Defined. +Inductive gpreg_q : Type := +| R0R1 | R2R3 | R4R5 | R6R7 | R8R9 +| R10R11 | R12R13 | R14R15 | R16R17 | R18R19 +| R20R21 | R22R23 | R24R25 | R26R27 | R28R29 +| R30R31 | R32R33 | R34R35 | R36R37 | R38R39 +| R40R41 | R42R43 | R44R45 | R46R47 | R48R49 +| R50R51 | R52R53 | R54R55 | R56R57 | R58R59 +| R60R61 | R62R63. + +Lemma gpreg_q_eq : forall (x y : gpreg_q), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Definition gpreg_q_expand (x : gpreg_q) : gpreg * gpreg := + match x with + | R0R1 => (GPR0, GPR1) + | R2R3 => (GPR2, GPR3) + | R4R5 => (GPR4, GPR5) + | R6R7 => (GPR6, GPR7) + | R8R9 => (GPR8, GPR9) + | R10R11 => (GPR10, GPR11) + | R12R13 => (GPR12, GPR13) + | R14R15 => (GPR14, GPR15) + | R16R17 => (GPR16, GPR17) + | R18R19 => (GPR18, GPR19) + | R20R21 => (GPR20, GPR21) + | R22R23 => (GPR22, GPR23) + | R24R25 => (GPR24, GPR25) + | R26R27 => (GPR26, GPR27) + | R28R29 => (GPR28, GPR29) + | R30R31 => (GPR30, GPR31) + | R32R33 => (GPR32, GPR33) + | R34R35 => (GPR34, GPR35) + | R36R37 => (GPR36, GPR37) + | R38R39 => (GPR38, GPR39) + | R40R41 => (GPR40, GPR41) + | R42R43 => (GPR42, GPR43) + | R44R45 => (GPR44, GPR45) + | R46R47 => (GPR46, GPR47) + | R48R49 => (GPR48, GPR49) + | R50R51 => (GPR50, GPR51) + | R52R53 => (GPR52, GPR53) + | R54R55 => (GPR54, GPR55) + | R56R57 => (GPR56, GPR57) + | R58R59 => (GPR58, GPR59) + | R60R61 => (GPR60, GPR61) + | R62R63 => (GPR62, GPR63) + end. + (** We model the following registers of the RISC-V architecture. *) (** basic register *) diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 47e04aec..2c73bb63 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -3,6 +3,28 @@ Require Import Asmvliw. Require Import Values. Require Import Integers. +Definition gpreg_q_list : list gpreg_q := +R0R1 :: R2R3 :: R4R5 :: R6R7 :: R8R9 +:: R10R11 :: R12R13 :: R14R15 :: R16R17 :: R18R19 +:: R20R21 :: R22R23 :: R24R25 :: R26R27 :: R28R29 +:: R30R31 :: R32R33 :: R34R35 :: R36R37 :: R38R39 +:: R40R41 :: R42R43 :: R44R45 :: R46R47 :: R48R49 +:: R50R51 :: R52R53 :: R54R55 :: R56R57 :: R58R59 +:: R60R61 :: R62R63 :: nil. + +Fixpoint gpreg_q_search_rec r0 r1 l := + match l with + | h :: t => + let (s0, s1) := gpreg_q_expand h in + if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) + then Some h + else gpreg_q_search_rec r0 r1 t + | nil => None + end. + +Definition gpreg_q_search (r0 : gpreg) (r1 : gpreg) : option gpreg_q := + gpreg_q_search_rec r0 r1 gpreg_q_list. + Parameter print_found_store : forall A : Type, Z -> A -> A. Fixpoint optimize_body (insns : list basic) : list basic := @@ -14,12 +36,16 @@ Fixpoint optimize_body (insns : list basic) : list basic := match h0, h1 with | (PStoreRRO Psd_a rs0 ra0 (Ofsimm ofs0)), (PStoreRRO Psd_a rs1 ra1 (Ofsimm ofs1)) => - let zofs0 := Ptrofs.signed ofs0 in - let zofs1 := Ptrofs.signed ofs1 in - if zofs1 =? zofs0 + 8 - then let h0' := print_found_store basic zofs0 h0 in - h0' :: (optimize_body t0) - else h0 :: (optimize_body t0) + match gpreg_q_search rs0 rs1 with + | Some rs0rs1 => + let zofs0 := Ptrofs.signed ofs0 in + let zofs1 := Ptrofs.signed ofs1 in + if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) + then let h0' := print_found_store basic zofs0 h0 in + h0' :: (optimize_body t0) + else h0 :: (optimize_body t0) + | None => h0 :: (optimize_body t0) + end | _, _ => h0 :: (optimize_body t0) end | nil => h0 :: nil -- cgit From 8163278174362fb8269804a7958f6e9e7878a511 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 03:33:58 +0200 Subject: getting stuck need to move offsets --- mppa_k1c/Asm.v | 5 ++++- mppa_k1c/Asmblockdeps.v | 11 ++++++++--- mppa_k1c/Asmvliw.v | 27 +++++++++++++++++++++------ mppa_k1c/lib/Asmblockgenproof0.v | 7 +++++++ 4 files changed, 40 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index d73d00c7..8b1c9a81 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -122,7 +122,9 @@ Inductive instruction : Type := | 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 (rd: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) (** Arith RR *) | Pmv (rd rs: ireg) (**r register move *) @@ -484,6 +486,7 @@ Definition basic_to_instruction (b: basic) := | 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) end. Section RELSEM. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 1ee5002c..04f02a80 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -639,6 +639,10 @@ Definition trans_basic (b: basic) : inst := | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] | 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))] + | PStoreQRRO qs a ofs => + let (s0, s1) := gpreg_q_expand qs in + [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); @@ -884,7 +888,10 @@ Proof. eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. -(* Allocframe *) + + unfold parexec_store_q_offset. + destruct (gpreg_q_expand rs) as [s0 s1]. + simpl. + (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. @@ -1529,5 +1536,3 @@ Definition bblock_equivb: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bbloc Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. End SECT_BBLOCK_EQUIV. - - diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 0cbe27e1..fb1575f9 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -236,9 +236,6 @@ Definition label := positive. *) Inductive ex_instruction : Type := (* Pseudo-instructions *) -(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) - | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) - | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) . @@ -341,6 +338,7 @@ Inductive st_instruction : Type := | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) | PStoreRRRXS(i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) + | PStoreQRRO (rs: gpreg_q) (ra: ireg) (ofs: offset) . (** Arithmetic instructions **) @@ -355,7 +353,6 @@ Inductive arith_name_rr : Type := | Pcvtl2w (**r Convert Long to Word *) | Psxwd (**r Sign Extend Word to Double Word *) | Pzxwd (**r Zero Extend Word to Double Word *) -(* | Pextfs (stop : int) (start : int) (**r extract bit field, signed *) *) | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) | Pextfzl (stop : Z) (start : Z) (**r extract bit field, unsigned *) @@ -693,7 +690,7 @@ Variable ge: genv. from the current state (a register set + a memory state) to either [Next rs' m'] where [rs'] and [m'] are the updated register set and memory state after execution of the instruction at [rs#PC], or [Stuck] if the processor is stuck. - + The parallel semantics of each instructions handles two states in input: - the actual input state of the bundle which is only read - and the other on which every "write" is performed: @@ -1198,6 +1195,23 @@ Definition parexec_store_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: m | Some m' => Next rsw m' end. +Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := + let (s0, s1) := gpreg_q_expand s in + match eval_offset ofs with + | OK eofs => + let base := Val.offset_ptr (rsr a) eofs in + match Mem.storev Many64 mr base (rsr s0) with + | None => Stuck + | Some m1 => + match Mem.storev Many64 m1 base (rsr s1) with + | None => Stuck + | Some m2 => Next rsw m2 + end + end + | _ => Stuck + end. + + Definition load_chunk n := match n with | Plb => Mint8signed @@ -1237,7 +1251,8 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro | PStoreRRRXS n s a ro => parexec_store_regxs (store_chunk n) rsr rsw mr mw s a ro - + | PStoreQRRO s a ofs => + parexec_store_q_offset rsr rsw mr mw s a ofs | Pallocframe sz pos => let (mw, stk) := Mem.alloc mr 0 sz in let sp := (Vptr stk Ptrofs.zero) in diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 0a83a903..a93cb28a 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -950,6 +950,13 @@ Proof. 1-10: try (unfold parexec_store_offset in H1; destruct (eval_offset ge 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. + - (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (eval_offset _ _) 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. -- cgit From 92b48e2aa6d24d1ad487c1d2a3644a57966c765e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 09:25:48 +0200 Subject: rm Ofslow (résidu du Risc-V, inutilisé et complique les preuves) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblock.v | 4 ++-- mppa_k1c/Asmblockdeps.v | 9 ++++---- mppa_k1c/Asmblockgen.v | 4 ++-- mppa_k1c/Asmblockgenproof1.v | 28 +++++++++++------------ mppa_k1c/Asmexpand.ml | 44 ++++++++++++++++++------------------ mppa_k1c/Asmvliw.v | 14 ++---------- mppa_k1c/PostpassSchedulingOracle.ml | 5 ++-- mppa_k1c/PostpassSchedulingproof.v | 38 ++++++++----------------------- mppa_k1c/TargetPrinter.ml | 4 +--- mppa_k1c/lib/Asmblockgenproof0.v | 4 ++-- 10 files changed, 61 insertions(+), 93 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 1988813f..9abc1ca1 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -264,13 +264,13 @@ 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 ge chunk rs rs m m d a ofs. +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_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_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_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset ge chunk rs rs m m s a ofs. +Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 1ee5002c..7cfcbff1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -135,7 +135,7 @@ Definition arith_eval (ao: arith_op) (l: list value) := Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in - match (eval_offset ge ofs) with + match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with | None => None | Some vl => Some (Val vl) @@ -165,7 +165,7 @@ Definition load_eval (lo: load_op) (l: list value) := Definition exec_store_deps_offset (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := let (ge, fn) := Ge in - match (eval_offset ge ofs) with + match (eval_offset ofs) with | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with | None => None | Some m' => Some (Memstate m') @@ -841,7 +841,8 @@ Proof. (* Load Offset *) + destruct i; simpl load_chunk. all: unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; - destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; + unfold eval_offset; + simpl; auto; destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. @@ -865,7 +866,7 @@ Proof. (* Store Offset *) + destruct i; simpl store_chunk. all: unfold parexec_store_offset; simpl; unfold exec_store_deps_offset; erewrite GENV, H, H0; rewrite (H0 ra); - destruct (eval_offset _ _) eqn:EVALOFF; simpl; auto; + unfold eval_offset; simpl; auto; destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ca7094da..dc55715a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -803,7 +803,7 @@ Definition indexed_memory_access (base: ireg) (ofs: ptrofs) := match make_immed64 (Ptrofs.to_int64 ofs) with | Imm64_single imm => - mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) + mk_instr base (Ptrofs.of_int64 imm) end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := @@ -868,7 +868,7 @@ Definition transl_memory_access do rs <- ireg_of a1; OK (indexed_memory_access mk_instr rs ofs ::i k) | Aglobal id ofs, nil => - OK (Ploadsymbol id ofs RTMP ::i (mk_instr RTMP (Ofsimm Ptrofs.zero) ::i k)) + OK (Ploadsymbol id ofs RTMP ::i (mk_instr RTMP Ptrofs.zero ::i k)) | Ainstack ofs, nil => OK (indexed_memory_access mk_instr SP ofs ::i k) | _, _ => diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index b265f221..c3ee28f1 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1872,7 +1872,7 @@ Lemma indexed_memory_access_correct: exists base' ofs' rs' ptr', exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m (mk_instr base' ofs' ::g k) rs' m - /\ eval_offset ge ofs' = OK ptr' + /\ eval_offset ofs' = OK ptr' /\ Val.offset_ptr rs'#base' ptr' = Val.offset_ptr rs#base ofs /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. @@ -1917,7 +1917,7 @@ Qed. Lemma indexed_load_access_correct: forall 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 ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset 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 -> base <> RTMP -> @@ -1938,7 +1938,7 @@ Qed. Lemma indexed_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) r1 m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> base <> RTMP -> r1 <> RTMP -> @@ -1974,7 +1974,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 ge (chunk_of_type ty) rs' m rd base' ofs'). + exec_load_offset (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. @@ -1996,7 +1996,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_store_offset ge (chunk_of_type ty) rs' m rr base' ofs'). + exec_store_offset (chunk_of_type ty) rs' m rr base' ofs'). { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; esplit; eauto. } destruct A as (mk_instr & rr & rsEq & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. @@ -2066,7 +2066,7 @@ Lemma transl_memory_access_correct: eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> exists base ofs rs' ptr, exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m - /\ eval_offset ge ofs = OK ptr + /\ eval_offset ofs = OK ptr /\ Val.offset_ptr rs'#base ptr = v /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. Proof. @@ -2183,7 +2183,7 @@ Qed. Lemma transl_load_access_correct: forall 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 ge chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset 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' -> @@ -2211,7 +2211,7 @@ Lemma transl_load_memory_access_ok: 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 ge chunk rs m rd base ofs. + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. @@ -2347,7 +2347,7 @@ Qed. Lemma transl_store_access_correct: forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset ge chunk rs m r1 base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 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.storev chunk m v rs#r1 = Some m' -> @@ -2368,16 +2368,16 @@ Qed. Remark exec_store_offset_8_sign rs m x base ofs: - exec_store_offset ge Mint8unsigned rs m x base ofs = exec_store_offset ge Mint8signed rs m x base ofs. + exec_store_offset Mint8unsigned rs m x base ofs = exec_store_offset Mint8signed rs m x base ofs. Proof. - unfold exec_store_offset. unfold parexec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. + unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. Qed. Remark exec_store_offset_16_sign rs m x base ofs: - exec_store_offset ge Mint16unsigned rs m x base ofs = exec_store_offset ge Mint16signed rs m x base ofs. + exec_store_offset Mint16unsigned rs m x base ofs = exec_store_offset Mint16signed rs m x base ofs. Proof. - unfold exec_store_offset. unfold parexec_store_offset. destruct (eval_offset _ _); auto. unfold Mem.storev. + unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. Qed. @@ -2391,7 +2391,7 @@ Lemma transl_store_memory_access_ok: preg_of src = IR rr /\ 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_store_offset ge chunk' rs m rr base ofs) + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk' rs m rr base ofs) /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). Proof. intros until m'. intros ? TR ? ?. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index ba771bcb..c49cfbd5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -154,10 +154,10 @@ 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 (Asmvliw.Ofsimm Z.zero))); + emit (Plb (tmpbuf, srcptr, AOff Z.zero)); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; - emit (Psb (tmpbuf, dstptr, AOff (Asmvliw.Ofsimm Z.zero))); + emit (Psb (tmpbuf, dstptr, AOff Z.zero)); emit (Paddil (dstptr, dstptr, Z.one)); emit Psemi; emit (Plabel lbl);; @@ -173,30 +173,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 (Asmvliw.Ofsimm ofs))) + emit (Plbu (res, base, AOff ofs)) | Mint8signed, BR(Asmvliw.IR res) -> - emit (Plb (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Plb (res, base, AOff ofs)) | Mint16unsigned, BR(Asmvliw.IR res) -> - emit (Plhu (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Plhu (res, base, AOff ofs)) | Mint16signed, BR(Asmvliw.IR res) -> - emit (Plh (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Plh (res, base, AOff ofs)) | Mint32, BR(Asmvliw.IR res) -> - emit (Plw (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Plw (res, base, AOff ofs)) | Mint64, BR(Asmvliw.IR res) -> - emit (Pld (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Pld (res, base, AOff ofs)) | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> let ofs' = Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, AOff (Asmvliw.Ofsimm ofs))); - emit (Plw (res1, base, AOff (Asmvliw.Ofsimm ofs'))) + emit (Plw (res2, base, AOff ofs)); + emit (Plw (res1, base, AOff ofs')) end else begin - emit (Plw (res1, base, AOff (Asmvliw.Ofsimm ofs'))); - emit (Plw (res2, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Plw (res1, base, AOff ofs')); + emit (Plw (res2, base, AOff ofs)) end | Mfloat32, BR(Asmvliw.IR res) -> - emit (Pfls (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Pfls (res, base, AOff ofs)) | Mfloat64, BR(Asmvliw.IR res) -> - emit (Pfld (res, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Pfld (res, base, AOff ofs)) | _ -> assert false @@ -215,21 +215,21 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk base ofs src = match chunk, src with | (Mint8signed | Mint8unsigned), BA(Asmvliw.IR src) -> - emit (Psb (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Psb (src, base, AOff ofs)) | (Mint16signed | Mint16unsigned), BA(Asmvliw.IR src) -> - emit (Psh (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Psh (src, base, AOff ofs)) | Mint32, BA(Asmvliw.IR src) -> - emit (Psw (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Psw (src, base, AOff ofs)) | Mint64, BA(Asmvliw.IR src) -> - emit (Psd (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Psd (src, base, AOff ofs)) | Mint64, BA_splitlong(BA(Asmvliw.IR src1), BA(Asmvliw.IR src2)) -> let ofs' = Ptrofs.add ofs _4 in - emit (Psw (src2, base, AOff (Asmvliw.Ofsimm ofs))); - emit (Psw (src1, base, AOff (Asmvliw.Ofsimm ofs'))) + emit (Psw (src2, base, AOff ofs)); + emit (Psw (src1, base, AOff ofs')) | Mfloat32, BA(Asmvliw.IR src) -> - emit (Pfss (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Pfss (src, base, AOff ofs)) | Mfloat64, BA(Asmvliw.IR src) -> - emit (Pfsd (src, base, AOff (Asmvliw.Ofsimm ofs))) + emit (Pfsd (src, base, AOff ofs)) | _ -> assert false diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e460727c..c25d4235 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -152,9 +152,7 @@ Inductive ftest: Type := (** Offsets for load and store instructions. An offset is either an immediate integer or the low part of a symbol. *) -Inductive offset : Type := - | Ofsimm (ofs: ptrofs) - | Ofslow (id: ident) (ofs: ptrofs). +Definition offset : Type := ptrofs. (** We model a subset of the K1c instruction set. In particular, we do not support floats yet. @@ -1093,15 +1091,7 @@ Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := | PArithARRI64 n d s i => rsw#d <- (arith_eval_arri64 n rsr#d rsr#s i) end. -Definition eval_offset (ofs: offset) : res ptrofs := - match ofs with - | Ofsimm n => OK n - | Ofslow id delta => - match (Genv.symbol_address ge id delta) with - | Vptr b ofs => OK ofs - | _ => Error (msg "Asmblock.eval_offset") - end - end. +Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. (** * load/store *) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index abc3dcb6..033cf943 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -544,9 +544,8 @@ 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 (Ofsimm ptr)) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) - | Some (Off (Ofslow (_, _))) -> Some E27U27L10 (* FIXME *) - (* I do not know yet in which context Ofslow can be used by CompCert *) + | Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) + and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 43c8acb8..47248e3e 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -96,11 +96,11 @@ Proof. Qed. Lemma exec_load_offset_pc_var: - forall ge t rs m rd ra ofs rs' m' v, - exec_load_offset ge t rs m rd ra ofs = Next rs' m' -> - exec_load_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + 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 ge ofs); try discriminate. + 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. @@ -129,12 +129,12 @@ Proof. Qed. Lemma exec_store_offset_pc_var: - forall ge t rs m rd ra ofs rs' m' v, - exec_store_offset ge t rs m rd ra ofs = Next rs' m' -> - exec_store_offset ge t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + 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 ge ofs); try discriminate. + destruct (eval_offset ofs); try discriminate. destruct (Mem.storev _ _ _). - inv H. apply next_eq; auto. - discriminate. @@ -600,32 +600,12 @@ Proof. unfold par_goto_label; unfold par_eval_branch; unfold par_goto_label; erewrite label_pos_preserved_blocks; eauto. Qed. -Lemma eval_offset_preserved: - forall ofs, eval_offset ge ofs = eval_offset tge ofs. -Proof. - intros. unfold eval_offset. destruct ofs; auto. erewrite symbol_address_preserved; eauto. -Qed. - -Lemma transf_exec_load_offset: - forall t rs m rd ra ofs, exec_load_offset ge t rs m rd ra ofs = exec_load_offset tge t rs m rd ra ofs. -Proof. - intros. unfold exec_load_offset. unfold parexec_load_offset. rewrite eval_offset_preserved. reflexivity. -Qed. - -Lemma transf_exec_store_offset: - forall t rs m rs0 ra ofs, exec_store_offset ge t rs m rs0 ra ofs = exec_store_offset tge t rs m rs0 ra ofs. -Proof. - intros. unfold exec_store_offset. unfold parexec_store_offset. rewrite eval_offset_preserved. reflexivity. -Qed. - 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 parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. - - apply transf_exec_load_offset. - - apply transf_exec_store_offset. + unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. Qed. Lemma transf_exec_body: diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 62b02f58..156b16d0 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -160,9 +160,7 @@ module Target (*: TARGET*) = *) (* Offset part of a load or store *) - let offset oc = let open Asmvliw in function - | Ofsimm n -> ptrofs oc n - | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) + let offset oc n = ptrofs oc n let addressing oc = function | AOff ofs -> offset oc ofs diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 0a83a903..130f0b12 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -944,10 +944,10 @@ Lemma exec_basic_instr_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 ge ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + 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 ge ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | 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. - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. -- cgit From da32340a8c063c9dc0847d01e7ec5c77ce75f3b1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 09:29:46 +0200 Subject: rm Ofslow --- mppa_k1c/lib/Asmblockgenproof0.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 0465618c..3bca6629 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -953,7 +953,7 @@ Proof. - (* PStoreQRRO *) unfold parexec_store_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (eval_offset _ _) in H1; try discriminate. + 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. -- cgit From 676d1ae6324d3c2f13e20efdcff3fbda9aab1686 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 10:14:13 +0200 Subject: ça avance MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmblockdeps.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2b6a8450..b2fa79d1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -890,8 +890,35 @@ Proof. intros rr; destruct rr; Simpl. + unfold parexec_store_q_offset. + simpl. destruct (gpreg_q_expand rs) as [s0 s1]. simpl. + unfold exec_store_deps_offset. + repeat rewrite H0. + repeat rewrite H. + destruct Ge. + destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ] eqn:MEML0; simpl. + ++ rewrite MEML0. + destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ] eqn:MEML1; simpl. + * rewrite (assign_diff sr _ (# s1)) by apply ppos_pmem_discr. + rewrite (assign_diff sr _ (# ra)) by apply ppos_pmem_discr. + repeat rewrite H0. + rewrite MEML1. + eexists; split. + reflexivity. + rewrite (assign_eq _ pmem). + split; trivial. + intro r. + rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. + rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. + congruence. + * rewrite (assign_diff sr pmem (# s1)) by apply ppos_pmem_discr. + rewrite (assign_diff sr pmem (# ra)) by apply ppos_pmem_discr. + repeat rewrite H0. + rewrite MEML1. + reflexivity. + ++ rewrite MEML0. + reflexivity. (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. -- cgit From e1c864b670812eda55e0ee129855c69d32c8b84a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 10:34:58 +0200 Subject: it compiles --- mppa_k1c/Asmblock.v | 2 ++ mppa_k1c/Peephole.v | 4 ++-- mppa_k1c/PostpassSchedulingOracle.ml | 7 +++++- mppa_k1c/PostpassSchedulingproof.v | 14 ++++++++++++ mppa_k1c/TargetPrinter.ml | 43 ++++++++++++++++++++++++++++++++++-- 5 files changed, 65 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9abc1ca1..f2c4a382 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -272,6 +272,8 @@ Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. +Definition exec_store_q_offset (rs: regset) (m: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := parexec_store_q_offset rs rs m m s a ofs. + Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_regxs chunk rs rs m m s a ro. diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 2c73bb63..91936ac6 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -34,8 +34,8 @@ Fixpoint optimize_body (insns : list basic) : list basic := match t0 with | h1 :: t1 => match h0, h1 with - | (PStoreRRO Psd_a rs0 ra0 (Ofsimm ofs0)), - (PStoreRRO Psd_a rs1 ra1 (Ofsimm ofs1)) => + | (PStoreRRO Psd_a rs0 ra0 ofs0), + (PStoreRRO Psd_a rs1 ra1 ofs1) => match gpreg_q_search rs0 rs1 with | Some rs0rs1 => let zofs0 := Ptrofs.signed ofs0 in diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 033cf943..c944774a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -222,7 +222,12 @@ let load_rec i = match i with { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} 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)) + | 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} + | 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} | 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} diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 47248e3e..da64c41d 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -140,6 +140,19 @@ Proof. - 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_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' -> @@ -182,6 +195,7 @@ Proof. + 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. - 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. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 156b16d0..7eea7d15 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -41,6 +41,7 @@ module Target (*: TARGET*) = let print_label oc lbl = label oc (transl_label lbl) let int_reg_name = let open Asmvliw in function + | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" @@ -60,7 +61,43 @@ module Target (*: TARGET*) = let ireg oc r = output_string oc (int_reg_name r) - let ireg = ireg + let int_gpreg_q_name = + let open Asmvliw in + function + | R0R1 -> "$r0r1" + | R2R3 -> "$r2r3" + | R4R5 -> "$r4r5" + | R6R7 -> "$r6r7" + | R8R9 -> "$r8r9" + | R10R11 -> "$r10r11" + | R12R13 -> "$r12r13" + | R14R15 -> "$r14r15" + | R16R17 -> "$r16r17" + | R18R19 -> "$r18r19" + | R20R21 -> "$r20r21" + | R22R23 -> "$r22r23" + | R24R25 -> "$r24r25" + | R26R27 -> "$r26r27" + | R28R29 -> "$r28r29" + | R30R31 -> "$r30r31" + | R32R33 -> "$r32r33" + | R34R35 -> "$r34r35" + | R36R37 -> "$r36r37" + | R38R39 -> "$r38r39" + | R40R41 -> "$r40r41" + | R42R43 -> "$r42r43" + | R44R45 -> "$r44r45" + | R46R47 -> "$r46r47" + | R48R49 -> "$r48r49" + | R50R51 -> "$r50r51" + | R52R53 -> "$r52r53" + | R54R55 -> "$r54r55" + | R56R57 -> "$r56r57" + | R58R59 -> "$r58r59" + | R60R61 -> "$r60r61" + | R62R63 -> "$r62r63" + + let gpreg_q oc r = output_string oc (int_gpreg_q_name r) let preg oc = let open Asmvliw in function | IR r -> ireg oc r @@ -364,7 +401,9 @@ module Target (*: TARGET*) = fprintf oc " sw%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd | Psd(rd, ra, adr) | Psd_a(rd, ra, adr) | Pfsd(rd, ra, adr) -> assert Archi.ptr64; fprintf oc " sd%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd - + | Psq(rd, ra, adr) -> + fprintf oc " sq%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_q rd + (* Arith R instructions *) (* Arith RR instructions *) -- cgit From 6783207fa4282f53af1da8bf09e4819716acde64 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 3 May 2019 10:43:38 +0200 Subject: Fixing mppa_k1c/Chunks.v for Coq 8.9 --- mppa_k1c/Chunks.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Chunks.v b/mppa_k1c/Chunks.v index 833f8116..40778877 100644 --- a/mppa_k1c/Chunks.v +++ b/mppa_k1c/Chunks.v @@ -1,10 +1,12 @@ Require Import AST. Require Import Values. Require Import Integers. +Require Import Coq.ZArith.BinIntDef. +Require Import BinNums. Local Open Scope Z_scope. -Definition zscale_of_chunk (chunk: memory_chunk) := +Definition zscale_of_chunk (chunk: memory_chunk) : Z := match chunk with | Mint8signed => 0 | Mint8unsigned => 0 -- cgit From fb77ce264f957a1ee3f87e537b55afbb10785ecf Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 3 May 2019 10:43:53 +0200 Subject: Renaming "dumb" scheduling into "greedy" --- mppa_k1c/InstructionScheduler.ml | 2 +- mppa_k1c/InstructionScheduler.mli | 2 +- mppa_k1c/PostpassSchedulingOracle.ml | 9 ++------- 3 files changed, 4 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index f9f99b1f..1fa55c9b 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -364,7 +364,7 @@ let bundles_to_schedule problem bundles : solution = end ) bundles; schedule;; -let dumb_scheduler (problem : problem) : solution option = +let greedy_scheduler (problem : problem) : solution option = let bundles = make_bundles problem 0 in Some (bundles_to_schedule problem bundles);; diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli index 701ccb25..f91c2d06 100644 --- a/mppa_k1c/InstructionScheduler.mli +++ b/mppa_k1c/InstructionScheduler.mli @@ -63,7 +63,7 @@ Once a clock tick is full go to the next. val list_scheduler : problem -> solution option (** Schedule the problem using the order of instructions without any reordering *) -val dumb_scheduler : problem -> solution option +val greedy_scheduler : problem -> solution option (** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) val schedule_reversed : scheduler -> problem -> int array option diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 033cf943..cf1d8e55 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -770,13 +770,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 = "dumb" then - dumb_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem - (* in let solution = validated_scheduler - (if !Clflags.option_fpostpass_ilp - then cascaded_scheduler - else dumb_scheduler) problem *) - (* in let solution = dumb_scheduler problem *) + else if !Clflags.option_fpostpass_sched = "greedy" then + greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem in match solution with | None -> failwith "Could not find a valid schedule" | Some sol -> let bundles = bundlize_solution bb sol in -- cgit From a289d73e791be5a760c8a9b2f3de2064f001a770 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 11:17:57 +0200 Subject: use sq to save pairs of registers --- mppa_k1c/Asmblockdeps.v | 19 ++++++++++++++++--- mppa_k1c/Asmvliw.v | 5 ++--- mppa_k1c/Peephole.v | 2 +- mppa_k1c/PostpassSchedulingOracle.ml | 10 +++++++--- mppa_k1c/TargetPrinter.ml | 2 +- 5 files changed, 27 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b2fa79d1..52af8cdf 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -387,11 +387,23 @@ Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. +Definition offset_eq (ofs1 ofs2 : offset): ?? bool := + RET (Ptrofs.eq ofs1 ofs2). + +Lemma offset_eq_correct ofs1 ofs2: + WHEN offset_eq ofs1 ofs2 ~> b THEN b = true -> ofs1 = ofs2. +Proof. + wlp_simplify. + pose (Ptrofs.eq_spec ofs1 ofs2). + rewrite H in *. + trivial. +Qed. +Hint Resolve offset_eq_correct: wlp. Definition store_op_eq (o1 o2: store_op): ?? bool := match o1 with | OStoreRRO n1 ofs1 => - match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (phys_eq ofs1 ofs2) | _ => RET false end + match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end | OStoreRRR n1 => match o2 with OStoreRRR n2 => phys_eq n1 n2 | _ => RET false end | OStoreRRRXS n1 => @@ -402,7 +414,8 @@ Lemma store_op_eq_correct o1 o2: WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. - - congruence. + - f_equal. pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. - congruence. - congruence. Qed. @@ -642,7 +655,7 @@ Definition trans_basic (b: basic) : inst := | PStoreQRRO qs a ofs => let (s0, s1) := gpreg_q_expand qs in [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); - (pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 248b8660..6ebc8340 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1189,11 +1189,10 @@ Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) ( let (s0, s1) := gpreg_q_expand s in match eval_offset ofs with | OK eofs => - let base := Val.offset_ptr (rsr a) eofs in - match Mem.storev Many64 mr base (rsr s0) with + match Mem.storev Many64 mr (Val.offset_ptr (rsr a) eofs) (rsr s0) with | None => Stuck | Some m1 => - match Mem.storev Many64 m1 base (rsr s1) with + match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add eofs (Ptrofs.repr 8))) (rsr s1) with | None => Stuck | Some m2 => Next rsw m2 end diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 91936ac6..3e0d9ae9 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -42,7 +42,7 @@ Fixpoint optimize_body (insns : list basic) : list basic := let zofs1 := Ptrofs.signed ofs1 in if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) then let h0' := print_found_store basic zofs0 h0 in - h0' :: (optimize_body t0) + (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (optimize_body t1) else h0 :: (optimize_body t0) | None => h0 :: (optimize_body t0) end diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c944774a..f88acb44 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -446,7 +446,7 @@ type real_instruction = | Make | Nop | Extfz | Extfs | Insf (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld - | Sb | Sh | Sw | Sd + | Sb | Sh | Sw | Sd | Sq (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) @@ -523,6 +523,7 @@ let ab_inst_to_real = function | "Psh" -> Sh | "Psw" | "Psw_a" | "Pfss" -> Sw | "Psd" | "Psd_a" | "Pfsd" -> Sd + | "Psq" -> Sq | "Pcb" | "Pcbu" -> Cb | "Pcall" | "Pdiv" | "Pdivu" -> Call @@ -543,6 +544,9 @@ let ab_inst_to_real = function | "Pfsbfw" -> Fsbfw | "Pfmuld" -> Fmuld | "Pfmulw" -> Fmulw + + | "nop" -> Nop + | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s exception InvalidEncoding @@ -595,7 +599,7 @@ let rec_to_usage r = (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) - | Sb | Sh | Sw | Sd -> + | Sb | Sh | Sw | Sd | Sq -> (match encoding with None | Some U6 | Some S10 -> lsu_acc | Some U27L5 | Some U27L10 -> lsu_acc_x | Some E27U27L10 -> lsu_acc_y) @@ -617,7 +621,7 @@ let real_inst_to_latency = function | 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 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> 3 - | Sb | Sh | Sw | Sd -> 1 (* See k1c-Optimization.pdf page 19 *) + | Sb | Sh | Sw | Sd | Sq -> 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 *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 7eea7d15..9d42169a 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -287,7 +287,7 @@ module Target (*: TARGET*) = | _ -> assert false end - | Pnop -> fprintf oc " nop\n" + | Pnop -> (* FIXME fprintf oc " nop\n" *) () | Psemi -> fprintf oc ";;\n" | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs -- cgit From cba53c98b999eea7984e4ffd24a9449abea3e0e2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 11:29:40 +0200 Subject: -fcoalesce-mem --- mppa_k1c/Peephole.v | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 3e0d9ae9..6e06e7ea 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 Compopts. Definition gpreg_q_list : list gpreg_q := R0R1 :: R2R3 :: R4R5 :: R6R7 :: R8R9 @@ -25,9 +26,9 @@ Fixpoint gpreg_q_search_rec r0 r1 l := Definition gpreg_q_search (r0 : gpreg) (r1 : gpreg) : option gpreg_q := gpreg_q_search_rec r0 r1 gpreg_q_list. -Parameter print_found_store : forall A : Type, Z -> A -> A. +Parameter print_found_store: forall A, Z -> A -> A. -Fixpoint optimize_body (insns : list basic) : list basic := +Fixpoint coalesce_mem (insns : list basic) : list basic := match insns with | nil => nil | h0 :: t0 => @@ -41,17 +42,21 @@ Fixpoint optimize_body (insns : list basic) : list basic := let zofs0 := Ptrofs.signed ofs0 in let zofs1 := Ptrofs.signed ofs1 in if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) - then let h0' := print_found_store basic zofs0 h0 in - (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (optimize_body t1) - else h0 :: (optimize_body t0) - | None => h0 :: (optimize_body t0) + then (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + else h0 :: (coalesce_mem t0) + | None => h0 :: (coalesce_mem t0) end - | _, _ => h0 :: (optimize_body t0) + | _, _ => h0 :: (coalesce_mem t0) end | nil => h0 :: nil end end. +Definition optimize_body (insns : list basic) := + if Compopts.optim_coalesce_mem tt + then coalesce_mem insns + else insns. + Program Definition optimize_bblock (bb : bblock) := let optimized := optimize_body (body bb) in let wf_ok := wf_bblockb optimized (exit bb) in -- cgit From b6d91977d837c40f243498ae900c5d1abc32f0f2 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 3 May 2019 11:50:24 +0200 Subject: [FIX #101] PostpassSchedulingOracle:separate_opaque was not computing correctly --- mppa_k1c/PostpassSchedulingOracle.ml | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a4dc3614..327e6c4b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -823,19 +823,25 @@ let is_opaque = function | PBasic (Pallocframe _) | PBasic (Pfreeframe _) | PControl (PExpand (Pbuiltin _)) -> true | _ -> false +(* Returns : (accumulated instructions, remaining instructions, opaque instruction if found) *) let rec biggest_wo_opaque = function - | [] -> ([], []) - | [i] -> ([i], []) - | i1 :: i2 :: li -> if is_opaque i2 || is_opaque i1 then ([i1], i2::li) - else let big, rem = biggest_wo_opaque li in (i1 :: i2 :: big, rem) + | [] -> ([], [], None) + | i :: li -> if is_opaque i then ([], li, Some i) + else let big, rem, opaque = biggest_wo_opaque li in (i :: big, rem, opaque);; let separate_opaque bb = let instrs = bb_to_instrs bb - in let rec f hd = function - | [] -> [] - | li -> - let sub_li, li = biggest_wo_opaque li - in (bundlize sub_li hd) :: (f [] li) + in let rec f hd li = + match li with + | [] -> [] + | li -> let big, rem, opaque = biggest_wo_opaque li in + match opaque with + | Some i -> + (match big with + | [] -> (bundlize [i] hd) :: (f [] rem) + | big -> (bundlize big hd) :: (bundlize [i] []) :: (f [] rem) + ) + | None -> (bundlize big hd) :: (f [] rem) in f bb.header instrs let smart_schedule bb = -- cgit From 919d1dfbf22967ae9686d5b982b51cfa707b5edd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 16:32:35 +0200 Subject: begin add Plq --- mppa_k1c/Asm.v | 5 ++- mppa_k1c/Asmblock.v | 2 ++ mppa_k1c/Asmblockdeps.v | 60 ++++++++++++++++++++++++++++++++++-- mppa_k1c/Asmvliw.v | 31 +++++++++++++------ mppa_k1c/PostpassSchedulingOracle.ml | 3 ++ mppa_k1c/PostpassSchedulingproof.v | 19 ++++++++++++ mppa_k1c/TargetPrinter.ml | 2 ++ mppa_k1c/lib/Asmblockgenproof0.v | 7 +++++ 8 files changed, 117 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 8b1c9a81..70d39168 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -112,7 +112,8 @@ Inductive instruction : Type := | 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 *) + | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) (** Stores **) | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) @@ -436,6 +437,8 @@ Definition basic_to_instruction (b: basic) := | 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) + | 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) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index f2c4a382..d9fbbdaa 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -270,6 +270,8 @@ Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ir 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_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. + Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. Definition exec_store_q_offset (rs: regset) (m: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := parexec_store_q_offset rs rs m m s a ofs. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 52af8cdf..ee4a9b51 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -650,6 +650,14 @@ Definition trans_basic (b: basic) : inst := | 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))] | 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 + if ireg_eq d0 a + then [(#d0, Op Fail Enil); + (#d1, Op Fail Enil)] + else + [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#a) @ PReg pmem @ Enil))] | 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))] | PStoreQRRO qs a ofs => @@ -842,7 +850,7 @@ Proof. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. Qed. - + Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Ge = Genv ge fn -> match_states (State rsr mr) sr -> @@ -877,7 +885,55 @@ Proof. destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - + + unfold parexec_load_q_offset. + destruct (gpreg_q_expand rd) as [rd0 rd1]. + destruct (ireg_eq rd0 ra) as [ OVERLAP0 | NOOVERLAP0 ]. + simpl. trivial. + unfold exec_load_deps_offset. + destruct Ge. + unfold eval_offset. + repeat rewrite H0. + destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. + ++ destruct (Mem.loadv Many64 mr + (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. + +++ rewrite H0. + rewrite H. + rewrite MEML0. + rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. + rewrite MEML1. + eexists; split. + * f_equal. + * constructor. + ** repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + assumption. + ** intro. + destruct (preg_eq r rd1). + *** subst r. + rewrite (assign_eq _ (# rd1)). + rewrite Pregmap.gss. + reflexivity. + *** rewrite (assign_diff _ (#rd1) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). + rewrite Pregmap.gso by assumption. + destruct (preg_eq r rd0). + **** subst r. + rewrite (assign_eq _ (# rd0)). + rewrite Pregmap.gss. + reflexivity. + **** rewrite (assign_diff _ (#rd0) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). + rewrite Pregmap.gso by assumption. + trivial. + +++ rewrite H0. rewrite H. rewrite MEML0. + rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. + rewrite MEML1. + constructor. + ++ rewrite H0. rewrite H. rewrite MEML0. trivial. + (* Store *) - destruct i. (* Store Offset *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 6ebc8340..30263b4d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -318,6 +318,7 @@ 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) + | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) . (** Stores **) @@ -1152,6 +1153,20 @@ Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: m | _ => Stuck end. +Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := + let (rd0, rd1) := gpreg_q_expand d in + if ireg_eq rd0 a + then Stuck + else + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with + | None => Stuck + | Some v0 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with + | None => Stuck + | Some v1 => Next (rsw#rd0 <- v0 #rd1 <- v1) mw + end + end. + Definition parexec_load_reg (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 @@ -1187,17 +1202,13 @@ Definition parexec_store_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: m Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := let (s0, s1) := gpreg_q_expand s in - match eval_offset ofs with - | OK eofs => - match Mem.storev Many64 mr (Val.offset_ptr (rsr a) eofs) (rsr s0) with + match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with + | None => Stuck + | Some m1 => + match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with | None => Stuck - | Some m1 => - match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add eofs (Ptrofs.repr 8))) (rsr s1) with - | None => Stuck - | Some m2 => Next rsw m2 - end + | Some m2 => Next rsw m2 end - | _ => Stuck end. @@ -1236,6 +1247,8 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | 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 => + parexec_load_q_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 | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a4dc3614..e3d43237 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -218,6 +218,9 @@ let arith_rec i = 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} + | 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} | 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} diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index da64c41d..0ceff6e5 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -128,6 +128,24 @@ Proof. - 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_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' -> @@ -191,6 +209,7 @@ Proof. + 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. - destruct i. + exploreInst; apply exec_store_offset_pc_var; auto. + exploreInst; apply exec_store_reg_pc_var; auto. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 9d42169a..326b802d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -392,6 +392,8 @@ module Target (*: TARGET*) = 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 + | Plq(rd, ra, adr) -> + fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra | Psb(rd, ra, adr) -> fprintf oc " sb%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 3bca6629..9303b780 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -950,6 +950,13 @@ Proof. 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 (ireg_eq _ _) 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. -- cgit From 3916ecbc8c77c99bab0bd69de184ae432fd9d3f4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 3 May 2019 16:48:07 +0200 Subject: Lq finished ? --- mppa_k1c/Asmblockdeps.v | 31 ++++++++++++++++--------------- mppa_k1c/Peephole.v | 11 +++++++++++ mppa_k1c/PostpassSchedulingOracle.ml | 7 ++++--- 3 files changed, 31 insertions(+), 18 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index ee4a9b51..225c3e98 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -366,10 +366,23 @@ Qed. Hint Resolve arith_op_eq_correct: wlp. Opaque arith_op_eq_correct. +Definition offset_eq (ofs1 ofs2 : offset): ?? bool := + RET (Ptrofs.eq ofs1 ofs2). + +Lemma offset_eq_correct ofs1 ofs2: + WHEN offset_eq ofs1 ofs2 ~> b THEN b = true -> ofs1 = ofs2. +Proof. + wlp_simplify. + pose (Ptrofs.eq_spec ofs1 ofs2). + rewrite H in *. + trivial. +Qed. +Hint Resolve offset_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) (phys_eq ofs1 ofs2) | _ => RET false end + 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 => @@ -380,26 +393,14 @@ 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. - - congruence. + - f_equal. pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. - congruence. - congruence. Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. -Definition offset_eq (ofs1 ofs2 : offset): ?? bool := - RET (Ptrofs.eq ofs1 ofs2). - -Lemma offset_eq_correct ofs1 ofs2: - WHEN offset_eq ofs1 ofs2 ~> b THEN b = true -> ofs1 = ofs2. -Proof. - wlp_simplify. - pose (Ptrofs.eq_spec ofs1 ofs2). - rewrite H in *. - trivial. -Qed. -Hint Resolve offset_eq_correct: wlp. - Definition store_op_eq (o1 o2: store_op): ?? bool := match o1 with | OStoreRRO n1 ofs1 => diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 6e06e7ea..3603c1d8 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -46,6 +46,17 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := else h0 :: (coalesce_mem t0) | None => h0 :: (coalesce_mem t0) end + | (PLoadRRO Pld_a rd0 ra0 ofs0), + (PLoadRRO Pld_a rd1 ra1 ofs1) => + match gpreg_q_search rd0 rd1 with + | Some rd0rd1 => + let zofs0 := Ptrofs.signed ofs0 in + let zofs1 := Ptrofs.signed ofs1 in + if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) && negb (ireg_eq ra0 rd0) + then (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + else h0 :: (coalesce_mem t0) + | None => h0 :: (coalesce_mem t0) + end | _, _ => h0 :: (coalesce_mem t0) end | nil => h0 :: nil diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index e3d43237..d3f16366 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -448,7 +448,7 @@ type real_instruction = | Maddw | Maddd | Cmoved | Make | Nop | Extfz | Extfs | Insf (* LSU *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Sb | Sh | Sw | Sd | Sq (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set @@ -521,6 +521,7 @@ let ab_inst_to_real = function | "Plhu" -> Lhz | "Plw" | "Plw_a" | "Pfls" -> Lws | "Pld" | "Pfld" | "Pld_a" -> Ld + | "Plq" -> Lq | "Psb" -> Sb | "Psh" -> Sh @@ -598,7 +599,7 @@ let rec_to_usage r = | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | 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 -> + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq -> (match encoding with None | Some U6 | Some S10 -> lsu_data | Some U27L5 | Some U27L10 -> lsu_data_x | Some E27U27L10 -> lsu_data_y) @@ -623,7 +624,7 @@ let real_inst_to_latency = function -> 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 *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld -> 3 + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq -> 3 | Sb | Sh | Sw | Sd | Sq -> 1 (* See k1c-Optimization.pdf page 19 *) | Get -> 1 | Set -> 4 (* According to the manual should be 3, but I measured 4 *) -- cgit From 10963816f7f909e58afb0b12cc77c84f7f9c8b94 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 08:01:15 +0200 Subject: big proofs for so / lo --- mppa_k1c/Asm.v | 8 +- mppa_k1c/Asmblockdeps.v | 202 ++++++++++++++++++++++++++++++++++++++- mppa_k1c/Asmvliw.v | 84 +++++++++++++++- mppa_k1c/lib/Asmblockgenproof0.v | 18 ++++ 4 files changed, 306 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 70d39168..b928a48e 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -113,7 +113,8 @@ Inductive instruction : Type := | 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 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 *) @@ -125,7 +126,8 @@ Inductive instruction : Type := | 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 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 *) @@ -438,6 +440,7 @@ Definition basic_to_instruction (b: basic) := | 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) @@ -490,6 +493,7 @@ Definition basic_to_instruction (b: basic) := | 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. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 225c3e98..baaff273 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -654,17 +654,35 @@ Definition trans_basic (b: basic) : inst := | PLoadQRRO qd a ofs => let (d0, d1) := gpreg_q_expand qd in if ireg_eq d0 a - then [(#d0, Op Fail Enil); - (#d1, Op Fail Enil)] + then [(#d0, Op Fail Enil)] else [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#a) @ PReg pmem @ Enil))] + | PLoadORRO od a ofs => + match gpreg_o_expand od with + | (d0, d1, d2, d3) => + if (ireg_eq d0 a) || (ireg_eq d1 a) || (ireg_eq d2 a) + then [(#d0, Op Fail Enil)] + else + [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#a) @ PReg pmem @ Enil)); + (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (PReg (#a) @ PReg pmem @ Enil)); + (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (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))] | PStoreQRRO qs a ofs => let (s0, s1) := gpreg_q_expand qs in [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] + | PStoreORRO os a ofs => + match gpreg_o_expand os with + | (s0, s1, s2, s3) => + [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (PReg (#s2) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (PReg (#s3) @ PReg (#a) @ PReg pmem @ Enil))] + end | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); @@ -885,7 +903,9 @@ Proof. unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + + (* Load Quad word *) + unfold parexec_load_q_offset. destruct (gpreg_q_expand rd) as [rd0 rd1]. destruct (ireg_eq rd0 ra) as [ OVERLAP0 | NOOVERLAP0 ]. @@ -935,6 +955,106 @@ Proof. constructor. ++ rewrite H0. rewrite H. rewrite MEML0. trivial. + (* Load Octuple word *) + + unfold parexec_load_o_offset. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. + destruct (ireg_eq rd0 ra); simpl; trivial. + destruct (ireg_eq rd1 ra); simpl; trivial. + destruct (ireg_eq rd2 ra); simpl; trivial. + destruct Ge. + repeat rewrite H0. + destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. + { destruct (Mem.loadv Many64 mr + (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. + { destruct (Mem.loadv Many64 mr + (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 16)))) as [load2| ] eqn:MEML2. + { destruct (Mem.loadv Many64 mr + (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 24)))) as [load3| ] eqn:MEML3. + { rewrite H. + rewrite MEML0. + rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. + rewrite MEML1. + repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite H0. + repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. + rewrite MEML2. + repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite H0. + repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. + rewrite MEML3. + repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + econstructor; split; trivial. + constructor. + { repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). assumption. } + { intro. + destruct (preg_eq r rd3). + { subst r. rewrite assign_eq. rewrite Pregmap.gss. trivial. + } + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite Pregmap.gso by assumption. + destruct (preg_eq r rd2). + { subst r. rewrite assign_eq. + rewrite Pregmap.gss. trivial. + } + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite Pregmap.gso by assumption. + destruct (preg_eq r rd1). + { subst r. rewrite assign_eq. + rewrite Pregmap.gss. trivial. + } + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite Pregmap.gso by assumption. + destruct (preg_eq r rd0). + { subst r. rewrite assign_eq. + rewrite Pregmap.gss. trivial. + } + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite Pregmap.gso by assumption. + auto. + } + } + rewrite H. rewrite MEML0. + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML1. + repeat rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML2. + repeat rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML3. + constructor. + } + rewrite H. rewrite MEML0. + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML1. + repeat rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML2. + repeat rewrite assign_diff by (apply ppos_discr; congruence). + constructor. + } + rewrite H. rewrite MEML0. + rewrite assign_diff by (apply ppos_discr; congruence). + rewrite H0. + rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). + rewrite H. rewrite MEML1. + repeat rewrite assign_diff by (apply ppos_discr; congruence). + constructor. + } + rewrite H. rewrite MEML0. + constructor. (* Store *) - destruct i. (* Store Offset *) @@ -959,6 +1079,7 @@ Proof. eexists; split; try split; Simpl; intros rr; destruct rr; Simpl. + (* Store Quad Word *) + unfold parexec_store_q_offset. simpl. destruct (gpreg_q_expand rs) as [s0 s1]. @@ -989,6 +1110,81 @@ Proof. reflexivity. ++ rewrite MEML0. reflexivity. + + (* Store Ocuple Word *) + + unfold parexec_store_o_offset. + simpl. + destruct (gpreg_o_expand rs) as [[[s0 s1] s2] s3]. + simpl. + destruct Ge. + destruct (Mem.storev _ _ _ (rsr s0)) as [store0 | ] eqn:MEML0. + { destruct (Mem.storev _ _ _ (rsr s1)) as [store1 | ] eqn:MEML1. + { destruct (Mem.storev _ _ _ (rsr s2)) as [store2 | ] eqn:MEML2. + { destruct (Mem.storev _ _ _ (rsr s3)) as [store3 | ] eqn:MEML3. + { repeat (try rewrite H0; try rewrite H). + simpl. + rewrite MEML0. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H). + rewrite assign_eq. + rewrite MEML1. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H). + rewrite assign_eq. + rewrite MEML2. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H). + rewrite assign_eq. + rewrite MEML3. + econstructor; split; trivial. + split. + { repeat rewrite assign_eq. trivial. } + { intro. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + trivial. } + } + { + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML0. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML1. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML2. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML3. + trivial. + } + } + { + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML0. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML1. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML2. + trivial. + } + } + { + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML0. + repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML1. + trivial. + } + } + { + repeat (try rewrite H0; try rewrite H; simpl). + rewrite MEML0. + trivial. + } + (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 30263b4d..3fbc048c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -83,7 +83,7 @@ Inductive gpreg_q : Type := | R40R41 | R42R43 | R44R45 | R46R47 | R48R49 | R50R51 | R52R53 | R54R55 | R56R57 | R58R59 | R60R61 | R62R63. - + Lemma gpreg_q_eq : forall (x y : gpreg_q), {x=y} + {x<>y}. Proof. decide equality. Defined. @@ -123,6 +123,35 @@ Definition gpreg_q_expand (x : gpreg_q) : gpreg * gpreg := | R62R63 => (GPR62, GPR63) end. +Inductive gpreg_o : Type := +| R0R1R2R3 | R4R5R6R7 | R8R9R10R11 | R12R13R14R15 +| R16R17R18R19 | R20R21R22R23 | R24R25R26R27 | R28R29R30R31 +| R32R33R34R35 | R36R37R38R39 | R40R41R42R43 | R44R45R46R47 +| R48R49R50R51 | R52R53R54R55 | R56R57R58R59 | R60R61R62R63. + +Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := + match x with + | R0R1R2R3 => (GPR0, GPR1, GPR2, GPR3) + | R4R5R6R7 => (GPR4, GPR5, GPR6, GPR7) + | R8R9R10R11 => (GPR8, GPR9, GPR10, GPR11) + | R12R13R14R15 => (GPR12, GPR13, GPR14, GPR15) + | R16R17R18R19 => (GPR16, GPR17, GPR18, GPR19) + | R20R21R22R23 => (GPR20, GPR21, GPR22, GPR23) + | R24R25R26R27 => (GPR24, GPR25, GPR26, GPR27) + | R28R29R30R31 => (GPR28, GPR29, GPR30, GPR31) + | R32R33R34R35 => (GPR32, GPR33, GPR34, GPR35) + | R36R37R38R39 => (GPR36, GPR37, GPR38, GPR39) + | R40R41R42R43 => (GPR40, GPR41, GPR42, GPR43) + | R44R45R46R47 => (GPR44, GPR45, GPR46, GPR47) + | R48R49R50R51 => (GPR48, GPR49, GPR50, GPR51) + | R52R53R54R55 => (GPR52, GPR53, GPR54, GPR55) + | 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 *) @@ -319,6 +348,7 @@ Inductive ld_instruction : Type := | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) | PLoadRRRXS (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) . (** Stores **) @@ -338,6 +368,7 @@ Inductive st_instruction : Type := | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) | PStoreRRRXS(i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) | PStoreQRRO (rs: gpreg_q) (ra: ireg) (ofs: offset) + | PStoreORRO (rs: gpreg_o) (ra: ireg) (ofs: offset) . (** Arithmetic instructions **) @@ -1167,6 +1198,31 @@ Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a end end. +Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := + match gpreg_o_expand d with + | (rd0, rd1, rd2, rd3) => + if (ireg_eq rd0 a) || (ireg_eq rd1 a) || (ireg_eq rd2 a) + then Stuck + else + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with + | None => Stuck + | Some v0 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with + | None => Stuck + | Some v1 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) with + | None => Stuck + | Some v2 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) with + | None => Stuck + | Some v3 => + Next (rsw#rd0 <- v0 #rd1 <- v1 #rd2 <- v2 #rd3 <- v3) mw + end + end + end + end + end. + Definition parexec_load_reg (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 @@ -1211,6 +1267,27 @@ Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) ( end end. +Definition parexec_store_o_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := + match gpreg_o_expand s with + | (s0, s1, s2, s3) => + match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with + | None => Stuck + | Some m1 => + match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with + | None => Stuck + | Some m2 => + match Mem.storev Many64 m2 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) (rsr s2) with + | None => Stuck + | Some m3 => + match Mem.storev Many64 m3 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) (rsr s3) with + | None => Stuck + | Some m4 => Next rsw m4 + end + end + end + end + end. + Definition load_chunk n := match n with @@ -1249,12 +1326,17 @@ Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := | PLoadRRRXS n d a ro => parexec_load_regxs (load_chunk n) rsr rsw mr mw d a ro | PLoadQRRO d a ofs => parexec_load_q_offset rsr rsw mr mw d a ofs + | 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 | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro | PStoreRRRXS n s a ro => parexec_store_regxs (store_chunk n) rsr rsw mr mw s a ro | PStoreQRRO s a ofs => parexec_store_q_offset rsr rsw mr mw s a ofs + | PStoreORRO s a ofs => + parexec_store_o_offset rsr rsw mr mw s a ofs + | Pallocframe sz pos => let (mw, stk) := Mem.alloc mr 0 sz in let sp := (Vptr stk Ptrofs.zero) in diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 9303b780..e8835a82 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -957,6 +957,15 @@ Proof. 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 (orb _ _) 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. + 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. @@ -964,6 +973,15 @@ Proof. 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. -- cgit From 064d62912f52ddb8d6666bc546ca141ac6575d5a Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 4 May 2019 08:08:21 +0200 Subject: legere simplification de preuve --- mppa_k1c/Asmblockdeps.v | 96 ++++++++++++++----------------------------------- 1 file changed, 26 insertions(+), 70 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 225c3e98..e9769d83 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -888,53 +888,26 @@ Proof. intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + unfold parexec_load_q_offset. destruct (gpreg_q_expand rd) as [rd0 rd1]. - destruct (ireg_eq rd0 ra) as [ OVERLAP0 | NOOVERLAP0 ]. - simpl. trivial. + destruct (ireg_eq rd0 ra) as [ OVERLAP0 | NOOVERLAP0 ]; simpl; auto. unfold exec_load_deps_offset. destruct Ge. - unfold eval_offset. - repeat rewrite H0. - destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. - ++ destruct (Mem.loadv Many64 mr - (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. - +++ rewrite H0. - rewrite H. - rewrite MEML0. - rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML1. - eexists; split. - * f_equal. - * constructor. - ** repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - assumption. - ** intro. - destruct (preg_eq r rd1). - *** subst r. - rewrite (assign_eq _ (# rd1)). - rewrite Pregmap.gss. - reflexivity. - *** rewrite (assign_diff _ (#rd1) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). - rewrite Pregmap.gso by assumption. - destruct (preg_eq r rd0). - **** subst r. - rewrite (assign_eq _ (# rd0)). - rewrite Pregmap.gss. - reflexivity. - **** rewrite (assign_diff _ (#rd0) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). - rewrite Pregmap.gso by assumption. - trivial. - +++ rewrite H0. rewrite H. rewrite MEML0. - rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML1. - constructor. - ++ rewrite H0. rewrite H. rewrite MEML0. trivial. - + rewrite H0, H. + destruct (Mem.loadv Many64 mr _) as [load0 | ] eqn:MEML0; simpl; rewrite MEML0; auto. + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. + rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). + rewrite (assign_diff _ _ pmem); auto. + rewrite H0, H. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1; simpl; auto. + eexists; intuition eauto. + * rewrite !(assign_diff _ _ pmem); auto. + * destruct (preg_eq r rd1). + ** subst r. rewrite assign_eq, Pregmap.gss; auto. + ** rewrite (assign_diff _ (#rd1) (#r) _); auto. + rewrite Pregmap.gso; auto. + destruct (preg_eq r rd0). + *** subst r; rewrite assign_eq, Pregmap.gss; auto. + *** rewrite assign_diff, ?Pregmap.gso; auto. + (* Store *) - destruct i. (* Store Offset *) @@ -960,35 +933,18 @@ Proof. intros rr; destruct rr; Simpl. + unfold parexec_store_q_offset. - simpl. destruct (gpreg_q_expand rs) as [s0 s1]. simpl. unfold exec_store_deps_offset. - repeat rewrite H0. - repeat rewrite H. + rewrite !H0, !H. destruct Ge. - destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ] eqn:MEML0; simpl. - ++ rewrite MEML0. - destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ] eqn:MEML1; simpl. - * rewrite (assign_diff sr _ (# s1)) by apply ppos_pmem_discr. - rewrite (assign_diff sr _ (# ra)) by apply ppos_pmem_discr. - repeat rewrite H0. - rewrite MEML1. - eexists; split. - reflexivity. - rewrite (assign_eq _ pmem). - split; trivial. - intro r. - rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. - rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. - congruence. - * rewrite (assign_diff sr pmem (# s1)) by apply ppos_pmem_discr. - rewrite (assign_diff sr pmem (# ra)) by apply ppos_pmem_discr. - repeat rewrite H0. - rewrite MEML1. - reflexivity. - ++ rewrite MEML0. - reflexivity. + destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ] eqn:MEML0; simpl; + rewrite MEML0; auto. + Local Hint Resolve ppos_pmem_discr. + rewrite !assign_eq, !(assign_diff sr _ _), !H0; auto. + destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ] eqn:MEML1; simpl; auto. + eexists; intuition eauto. + rewrite !assign_diff; auto. (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. -- cgit From 21e8f7a5644c3e61b926d51b458f4b9465eaba22 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 08:34:40 +0200 Subject: it compiles! --- mppa_k1c/Asmblock.v | 4 ++++ mppa_k1c/PostpassSchedulingOracle.ml | 21 ++++++++++++------ mppa_k1c/PostpassSchedulingproof.v | 42 ++++++++++++++++++++++++++++++++++++ mppa_k1c/TargetPrinter.ml | 27 ++++++++++++++++++++++- 4 files changed, 87 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index d9fbbdaa..ddb7ce7d 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -272,10 +272,14 @@ Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (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. +Definition exec_load_o_offset (rs: regset) (m: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := parexec_load_o_offset rs rs m m d a ofs. + Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. Definition exec_store_q_offset (rs: regset) (m: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := parexec_store_q_offset rs rs m m s a ofs. +Definition exec_store_o_offset (rs: regset) (m: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := parexec_store_o_offset rs rs m m s a ofs. + Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_regxs chunk rs rs m m s a ro. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index bdf72ec5..5523752f 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -221,6 +221,9 @@ let load_rec i = match i with | 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} + | 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} @@ -232,6 +235,10 @@ let store_rec i = match i with 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} + | 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} @@ -448,8 +455,8 @@ type real_instruction = | Maddw | Maddd | Cmoved | Make | Nop | Extfz | Extfs | Insf (* LSU *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq - | Sb | Sh | Sw | Sd | Sq + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo + | Sb | Sh | Sw | Sd | Sq | So (* BCU *) | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set (* FPU *) @@ -522,12 +529,14 @@ let ab_inst_to_real = function | "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 @@ -599,11 +608,11 @@ let rec_to_usage r = | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | 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 -> + | 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) - | Sb | Sh | Sw | Sd | Sq -> + | 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) @@ -624,8 +633,8 @@ let real_inst_to_latency = function -> 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 *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq -> 3 - | Sb | Sh | Sw | Sd | Sq -> 1 (* See k1c-Optimization.pdf page 19 *) + | 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 *) diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 0ceff6e5..7ade517a 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -146,6 +146,30 @@ Proof. 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' -> @@ -171,6 +195,22 @@ Proof. 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' -> @@ -210,11 +250,13 @@ Proof. + 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. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 326b802d..a2318469 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -96,8 +96,29 @@ module Target (*: TARGET*) = | R58R59 -> "$r58r59" | R60R61 -> "$r60r61" | R62R63 -> "$r62r63" - + + let int_gpreg_o_name = + let open Asmvliw in + function + | R0R1R2R3 -> "$r0r1r2r3" + | R4R5R6R7 -> "$r4r5r6r7" + | R8R9R10R11 -> "$r8r9r10r11" + | R12R13R14R15 -> "$r12r13r14r15" + | R16R17R18R19 -> "$r16r17r18r19" + | R20R21R22R23 -> "$r20r21r22r23" + | R24R25R26R27 -> "$r24r25r26r27" + | R28R29R30R31 -> "$r28r29r30r31" + | R32R33R34R35 -> "$r32r33r34r35" + | R36R37R38R39 -> "$r36r37r38r39" + | R40R41R42R43 -> "$r40r41r42r43" + | R44R45R46R47 -> "$r44r45r46r47" + | R48R49R50R51 -> "$r48r49r50r51" + | R52R53R54R55 -> "$r52r53r54r55" + | R56R57R58R59 -> "$r56r57r58r59" + | R60R61R62R63 -> "$r60r61r62r63";; + let gpreg_q oc r = output_string oc (int_gpreg_q_name r) + let gpreg_o oc r = output_string oc (int_gpreg_o_name r) let preg oc = let open Asmvliw in function | IR r -> ireg oc r @@ -394,6 +415,8 @@ module Target (*: TARGET*) = fprintf oc " ld%a %a = %a[%a]\n" 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) -> + fprintf oc " lo%a %a = %a[%a]\n" xscale adr gpreg_o rd addressing adr ireg ra | Psb(rd, ra, adr) -> fprintf oc " sb%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd @@ -405,6 +428,8 @@ module Target (*: TARGET*) = fprintf oc " sd%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd | Psq(rd, ra, adr) -> fprintf oc " sq%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_q rd + | Pso(rd, ra, adr) -> + fprintf oc " so%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_o rd (* Arith R instructions *) -- cgit From 8b5cefb2a4935d6ed4aa1b3a965ba4b639f469c9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 09:03:45 +0200 Subject: store octuple --- mppa_k1c/Peephole.v | 39 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 3603c1d8..9fb0d898 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -13,6 +13,12 @@ R0R1 :: R2R3 :: R4R5 :: R6R7 :: R8R9 :: R50R51 :: R52R53 :: R54R55 :: R56R57 :: R58R59 :: R60R61 :: R62R63 :: nil. +Definition gpreg_o_list : list gpreg_o := +R0R1R2R3 :: R4R5R6R7 :: R8R9R10R11 :: R12R13R14R15 +:: R16R17R18R19 :: R20R21R22R23 :: R24R25R26R27 :: R28R29R30R31 +:: R32R33R34R35 :: R36R37R38R39 :: R40R41R42R43 :: R44R45R46R47 +:: R48R49R50R51 :: R52R53R54R55 :: R56R57R58R59 :: R60R61R62R63 :: nil. + Fixpoint gpreg_q_search_rec r0 r1 l := match l with | h :: t => @@ -23,9 +29,25 @@ Fixpoint gpreg_q_search_rec r0 r1 l := | nil => None end. +Fixpoint gpreg_o_search_rec r0 r1 r2 r3 l := + match l with + | h :: t => + match gpreg_o_expand h with + | (((s0, s1), s2), s3) => + if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) && + (gpreg_eq r2 s2) && (gpreg_eq r3 s3) + then Some h + else gpreg_o_search_rec r0 r1 r2 r3 t + end + | nil => None + end. + Definition gpreg_q_search (r0 : gpreg) (r1 : gpreg) : option gpreg_q := gpreg_q_search_rec r0 r1 gpreg_q_list. +Definition gpreg_o_search r0 r1 r2 r3 : option gpreg_o := + gpreg_o_search_rec r0 r1 r2 r3 gpreg_o_list. + Parameter print_found_store: forall A, Z -> A -> A. Fixpoint coalesce_mem (insns : list basic) : list basic := @@ -42,7 +64,22 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := let zofs0 := Ptrofs.signed ofs0 in let zofs1 := Ptrofs.signed ofs1 in if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) - then (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + then + match t1 with + | (PStoreRRO Psd_a rs2 ra2 ofs2) :: + (PStoreRRO Psd_a rs3 ra3 ofs3) :: t3 => + match gpreg_o_search rs0 rs1 rs2 rs3 with + | Some octuple => + let zofs2 := Ptrofs.signed ofs2 in + let zofs3 := Ptrofs.signed ofs3 in + if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && + (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) + then (PStore (PStoreORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) + else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + | None => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + | _ => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end else h0 :: (coalesce_mem t0) | None => h0 :: (coalesce_mem t0) end -- cgit From 5abd0529197507395b83fc44f1e1a6fb6ac0096e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 09:23:13 +0200 Subject: store o --- mppa_k1c/Peephole.v | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 9fb0d898..81f0dc82 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -50,6 +50,8 @@ Definition gpreg_o_search r0 r1 r2 r3 : option gpreg_o := Parameter print_found_store: forall A, Z -> A -> A. +Definition coalesce_octuples := true. + Fixpoint coalesce_mem (insns : list basic) : list basic := match insns with | nil => nil @@ -65,21 +67,24 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := let zofs1 := Ptrofs.signed ofs1 in if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) then - match t1 with - | (PStoreRRO Psd_a rs2 ra2 ofs2) :: - (PStoreRRO Psd_a rs3 ra3 ofs3) :: t3 => - match gpreg_o_search rs0 rs1 rs2 rs3 with - | Some octuple => - let zofs2 := Ptrofs.signed ofs2 in - let zofs3 := Ptrofs.signed ofs3 in - if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && - (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) - then (PStore (PStoreORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) - else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - | None => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + if coalesce_octuples + then + match t1 with + | (PStoreRRO Psd_a rs2 ra2 ofs2) :: + (PStoreRRO Psd_a rs3 ra3 ofs3) :: t3 => + match gpreg_o_search rs0 rs1 rs2 rs3 with + | Some octuple => + let zofs2 := Ptrofs.signed ofs2 in + let zofs3 := Ptrofs.signed ofs3 in + if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && + (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) + then (PStore (PStoreORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) + else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + | None => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + | _ => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) end - | _ => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - end + else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) else h0 :: (coalesce_mem t0) | None => h0 :: (coalesce_mem t0) end -- cgit From d193a67519e6aae60fcc31905714e5ed5dc828d0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 09:32:37 +0200 Subject: merged --- mppa_k1c/Asmblockdeps.v | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 77cc02e4..a9f14f8e 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -916,8 +916,7 @@ Proof. destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. ++ destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. - +++ rewrite H0. - rewrite H. + +++ rewrite H. rewrite MEML0. rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). rewrite H0. @@ -945,14 +944,14 @@ Proof. **** rewrite (assign_diff _ (#rd0) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). rewrite Pregmap.gso by assumption. trivial. - +++ rewrite H0. rewrite H. rewrite MEML0. + +++ rewrite H. rewrite MEML0. rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). rewrite H0. rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). rewrite H. rewrite MEML1. constructor. - ++ rewrite H0. rewrite H. rewrite MEML0. trivial. + ++ rewrite H. rewrite MEML0. trivial. (* Load Octuple word *) + unfold parexec_load_o_offset. -- cgit From 20fed399133f75a10599082c9f75d9a519efff52 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 09:44:17 +0200 Subject: generates lo --- mppa_k1c/Peephole.v | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 81f0dc82..7c8f65a8 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -88,6 +88,7 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := else h0 :: (coalesce_mem t0) | None => h0 :: (coalesce_mem t0) end + | (PLoadRRO Pld_a rd0 ra0 ofs0), (PLoadRRO Pld_a rd1 ra1 ofs1) => match gpreg_q_search rd0 rd1 with @@ -95,7 +96,26 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := let zofs0 := Ptrofs.signed ofs0 in let zofs1 := Ptrofs.signed ofs1 in if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) && negb (ireg_eq ra0 rd0) - then (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + then + if coalesce_octuples + then + match t1 with + | (PLoadRRO Pld_a rd2 ra2 ofs2) :: + (PLoadRRO Pld_a rd3 ra3 ofs3) :: t3 => + match gpreg_o_search rd0 rd1 rd2 rd3 with + | Some octuple => + let zofs2 := Ptrofs.signed ofs2 in + let zofs3 := Ptrofs.signed ofs3 in + if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && + (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) && + negb (ireg_eq ra0 rd1) && negb (ireg_eq ra0 rd2) + then (PLoad (PLoadORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) + else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + | None => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + | _ => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) else h0 :: (coalesce_mem t0) | None => h0 :: (coalesce_mem t0) end -- cgit From 37dbd4fe0a30f808fe64c747b2839d0bb428c01b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 4 May 2019 10:35:06 +0200 Subject: little fix --- mppa_k1c/Asmblockgenproof1.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c3ee28f1..19b1b1f1 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -2573,7 +2573,7 @@ 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. *) } } + rewrite FREE'. eauto. (* auto. *) } } * split. (* apply agree_nextinstr. *)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. -- cgit From 63b89dd75d1fe03b8e14166b5f9b0b930c083f05 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 5 May 2019 23:07:35 +0200 Subject: wrong srsd arith unit assignment --- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 5523752f..39a14727 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -603,9 +603,9 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld | Srsd -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) - | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) + | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | 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 -> -- cgit From 906a8553570ed17a8e90831c1d1df18d76e94154 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 6 May 2019 13:51:51 +0200 Subject: simplification semantique+preuve des load_q+load_o --- mppa_k1c/Asmblockdeps.v | 317 ++++++++----------------------------- mppa_k1c/Asmvliw.v | 14 +- mppa_k1c/PostpassSchedulingproof.v | 4 +- mppa_k1c/lib/Asmblockgenproof0.v | 6 +- 4 files changed, 74 insertions(+), 267 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a9f14f8e..7361ee81 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -653,21 +653,15 @@ Definition trans_basic (b: basic) : inst := | 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 - if ireg_eq d0 a - then [(#d0, Op Fail Enil)] - else [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#a) @ PReg pmem @ Enil))] + (#d1, Op (Load (OLoadRRO Pld_a (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) => - if (ireg_eq d0 a) || (ireg_eq d1 a) || (ireg_eq d2 a) - then [(#d0, Op Fail Enil)] - else [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#a) @ PReg pmem @ Enil)); - (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (PReg (#a) @ PReg pmem @ Enil)); - (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (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))] 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))] @@ -869,13 +863,23 @@ Proof. * intros rr; destruct rr; Simpl. destruct (ireg_eq g rd); subst; Simpl. Qed. - + + + Theorem forward_simu_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). Proof. + +(* a little tactic to automate reasoning on preg_eq *) +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. +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; + rewrite Pregmap.gso; auto. + intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). destruct bi; simpl. (* Arith *) @@ -903,156 +907,39 @@ Proof. unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Quad word *) + unfold parexec_load_q_offset. - destruct (gpreg_q_expand rd) as [rd0 rd1]. - destruct (ireg_eq rd0 ra) as [ OVERLAP0 | NOOVERLAP0 ]; simpl; auto. - unfold exec_load_deps_offset. - destruct Ge. - unfold eval_offset. - repeat rewrite H0. - destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. - ++ destruct (Mem.loadv Many64 mr - (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. - +++ rewrite H. - rewrite MEML0. - rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML1. - eexists; split. - * f_equal. - * constructor. - ** repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - assumption. - ** intro. - destruct (preg_eq r rd1). - *** subst r. - rewrite (assign_eq _ (# rd1)). - rewrite Pregmap.gss. - reflexivity. - *** rewrite (assign_diff _ (#rd1) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). - rewrite Pregmap.gso by assumption. - destruct (preg_eq r rd0). - **** subst r. - rewrite (assign_eq _ (# rd0)). - rewrite Pregmap.gss. - reflexivity. - **** rewrite (assign_diff _ (#rd0) (#r) _) by (apply ppos_discr; apply not_eq_sym; assumption). - rewrite Pregmap.gso by assumption. - trivial. - +++ rewrite H. rewrite MEML0. - rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML1. - constructor. - ++ rewrite H. rewrite MEML0. trivial. - + destruct (gpreg_q_expand rd) as [rd0 rd1]; destruct Ge; simpl. + rewrite H0, H. + destruct (Mem.loadv Many64 mr _) as [load0 | ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. + eexists; intuition eauto. + { rewrite !(assign_diff _ _ pmem); auto. } + { preg_eq_discr r rd1. + preg_eq_discr r rd0. } + (* Load Octuple word *) - + unfold parexec_load_o_offset. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. - destruct (ireg_eq rd0 ra); simpl; trivial. - destruct (ireg_eq rd1 ra); simpl; trivial. - destruct (ireg_eq rd2 ra); simpl; trivial. - destruct Ge. - repeat rewrite H0. - destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ] eqn:MEML0; simpl. - { destruct (Mem.loadv Many64 mr - (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ] eqn:MEML1. - { destruct (Mem.loadv Many64 mr - (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 16)))) as [load2| ] eqn:MEML2. - { destruct (Mem.loadv Many64 mr - (Val.offset_ptr (rsr ra) (Ptrofs.add ofs (Ptrofs.repr 24)))) as [load3| ] eqn:MEML3. - { rewrite H. - rewrite MEML0. - rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML1. - repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML2. - repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - rewrite H0. - repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. - rewrite MEML3. - repeat rewrite (assign_diff _ _ (# ra)) by (apply ppos_discr; congruence). - econstructor; split; trivial. - constructor. - { repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). assumption. } - { intro. - destruct (preg_eq r rd3). - { subst r. rewrite assign_eq. rewrite Pregmap.gss. trivial. - } - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite Pregmap.gso by assumption. - destruct (preg_eq r rd2). - { subst r. rewrite assign_eq. - rewrite Pregmap.gss. trivial. - } - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite Pregmap.gso by assumption. - destruct (preg_eq r rd1). - { subst r. rewrite assign_eq. - rewrite Pregmap.gss. trivial. - } - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite Pregmap.gso by assumption. - destruct (preg_eq r rd0). - { subst r. rewrite assign_eq. - rewrite Pregmap.gss. trivial. - } - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite Pregmap.gso by assumption. - auto. - } - } - rewrite H. rewrite MEML0. - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML1. - repeat rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML2. - repeat rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML3. - constructor. - } - rewrite H. rewrite MEML0. - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML1. - repeat rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - repeat rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML2. - repeat rewrite assign_diff by (apply ppos_discr; congruence). - constructor. - } - rewrite H. rewrite MEML0. - rewrite assign_diff by (apply ppos_discr; congruence). - rewrite H0. - rewrite (assign_diff _ _ pmem) by (apply not_eq_sym; apply ppos_pmem_discr). - rewrite H. rewrite MEML1. - repeat rewrite assign_diff by (apply ppos_discr; congruence). - constructor. - } - rewrite H. rewrite MEML0. - constructor. + + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. + unfold parexec_load_o_offset. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. + rewrite H0, H. + destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 16)))) as [load2| ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 24)))) as [load3| ]; simpl; auto. + eexists; intuition eauto. + { rewrite !(assign_diff _ _ pmem); auto. } + { preg_eq_discr r rd3. + preg_eq_discr r rd2. + preg_eq_discr r rd1. + preg_eq_discr r rd0. } + (* Store *) - destruct i. (* Store Offset *) @@ -1079,108 +966,28 @@ Proof. (* Store Quad Word *) + unfold parexec_store_q_offset. - destruct (gpreg_q_expand rs) as [s0 s1]. - simpl. - unfold exec_store_deps_offset. + destruct (gpreg_q_expand rs) as [s0 s1]; destruct Ge; simpl. rewrite !H0, !H. - destruct Ge. - destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ] eqn:MEML0; simpl. - ++ rewrite MEML0. - destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ] eqn:MEML1; simpl. - * rewrite (assign_diff sr _ (# s1)) by apply ppos_pmem_discr. - rewrite (assign_diff sr _ (# ra)) by apply ppos_pmem_discr. - repeat rewrite H0. - rewrite MEML1. - eexists; split. - reflexivity. - rewrite (assign_eq _ pmem). - split; trivial. - intro r. - rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. - rewrite (assign_diff _ _ (# r)) by apply ppos_pmem_discr. - congruence. - * rewrite (assign_diff sr pmem (# s1)) by apply ppos_pmem_discr. - rewrite (assign_diff sr pmem (# ra)) by apply ppos_pmem_discr. - repeat rewrite H0. - rewrite MEML1. - reflexivity. - ++ rewrite MEML0. - reflexivity. + destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ]; simpl; auto. + eexists; intuition eauto. + rewrite !assign_diff; auto. (* Store Ocuple Word *) + unfold parexec_store_o_offset. - simpl. - destruct (gpreg_o_expand rs) as [[[s0 s1] s2] s3]. - simpl. - destruct Ge. - destruct (Mem.storev _ _ _ (rsr s0)) as [store0 | ] eqn:MEML0. - { destruct (Mem.storev _ _ _ (rsr s1)) as [store1 | ] eqn:MEML1. - { destruct (Mem.storev _ _ _ (rsr s2)) as [store2 | ] eqn:MEML2. - { destruct (Mem.storev _ _ _ (rsr s3)) as [store3 | ] eqn:MEML3. - { repeat (try rewrite H0; try rewrite H). - simpl. - rewrite MEML0. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H). - rewrite assign_eq. - rewrite MEML1. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H). - rewrite assign_eq. - rewrite MEML2. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H). - rewrite assign_eq. - rewrite MEML3. - econstructor; split; trivial. - split. - { repeat rewrite assign_eq. trivial. } - { intro. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - trivial. } - } - { - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML0. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML1. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML2. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML3. - trivial. - } - } - { - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML0. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML1. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML2. - trivial. - } - } - { - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML0. - repeat rewrite (assign_diff _ _ _) by apply ppos_pmem_discr. - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML1. - trivial. - } - } - { - repeat (try rewrite H0; try rewrite H; simpl). - rewrite MEML0. - trivial. - } - + destruct (gpreg_o_expand rs) as [[[s0 s1] s2] s3]; destruct Ge; simpl. + rewrite !H0, !H. + destruct (Mem.storev _ _ _ (rsr s0)) as [store0 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s1)) as [store1 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s2)) as [store2 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s3)) as [store3 | ]; simpl; auto. + eexists; intuition eauto. + rewrite !assign_diff; auto. + (* Allocframe *) - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. * eexists; repeat split. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3fbc048c..3bef1a5c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1186,9 +1186,9 @@ Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: m Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := let (rd0, rd1) := gpreg_q_expand d in - if ireg_eq rd0 a - then Stuck - else +(* NB: By construction of [gpreg_q], register rd0 and rd1 are distinct, thus, the register writes cannot overlap. + But we do not need to express/prove this in the semantics. +*) match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with | None => Stuck | Some v0 => @@ -1201,10 +1201,10 @@ Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := match gpreg_o_expand d with | (rd0, rd1, rd2, rd3) => - if (ireg_eq rd0 a) || (ireg_eq rd1 a) || (ireg_eq rd2 a) - then Stuck - else - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with +(* NB: By construction of [gpreg_o], the four destination registers are pairwise distinct, thus, the register writes cannot overlap. + But we do not need to express/prove this in the semantics. +*) + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with | None => Stuck | Some v0 => match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 7ade517a..f470ef8a 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -135,7 +135,7 @@ Lemma exec_load_offset_q_pc_var: 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. + (* destruct (ireg_eq rd0 ra); try discriminate. *) rewrite Pregmap.gso; try discriminate. destruct (Mem.loadv _ _ _); try discriminate. inv H. @@ -153,9 +153,11 @@ Lemma exec_load_offset_o_pc_var: 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. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index e8835a82..a8da1cf1 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -953,19 +953,17 @@ Proof. - (* PLoadQRRO *) unfold parexec_load_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (ireg_eq _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. + inv H1. Simpl. - (* PLoadORRO *) unfold parexec_load_o_offset in H1. destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (orb _ _) 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. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. + inv H1. Simpl. - (* PStoreQRRO *) unfold parexec_store_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. -- cgit From 00d530aed30181dece1b32d4eb0ce122ed55ff89 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 6 May 2019 19:37:00 +0200 Subject: one cycle less in allocframe --- mppa_k1c/Asmexpand.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index c49cfbd5..94846793 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -459,9 +459,9 @@ let expand_instruction instr = vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin - expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg sz)); - emit Psemi; - expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; + let below = Ptrofs.repr (Z.neg sz) in + expand_addptrofs stack_pointer stack_pointer below; + expand_storeind_ptr Asmvliw.GPR17 stack_pointer (Ptrofs.add ofs below); emit Psemi; vararg_start_ofs := None end -- cgit From 579ce1d6d18371b753fff2dac7305e13b85b8cab Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 7 May 2019 08:37:05 +0200 Subject: generalize bblock_equiv into bblock_simu --- mppa_k1c/Asmblockdeps.v | 32 ++++++++++++++++---------------- mppa_k1c/PostpassScheduling.v | 14 +++++++------- mppa_k1c/PostpassSchedulingproof.v | 2 +- mppa_k1c/lib/Asmblockgenproof0.v | 9 ++++----- 4 files changed, 28 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 7361ee81..c6207627 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1297,14 +1297,13 @@ Variable Ge: genv. Local Hint Resolve trans_state_match. -Lemma bblock_equiv_reduce: +Lemma bblock_simu_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_equiv Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_equiv ge fn p1 p2. + Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. - unfold bblock_equiv, res_eq; intros p1 p2 ge fn H1 H2; constructor. - intros rs m. + 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. @@ -1599,37 +1598,38 @@ Definition string_of_op (op: P.op): ?? pstring := | Fail => RET (Str "Fail") end. -Definition bblock_eq_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := +Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) else IDT.bblock_eq_test (trans_block p1) (trans_block p2). -Local Hint Resolve IDT.bblock_eq_test_correct bblock_equiv_reduce IDT.verb_bblock_eq_test_correct: wlp. +Local Hint Resolve IDT.bblock_eq_test_correct bblock_simu_reduce IDT.verb_bblock_eq_test_correct: wlp. -Theorem bblock_eq_test_correct verb p1 p2 : - WHEN bblock_eq_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. +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. Proof. wlp_simplify. Qed. -Hint Resolve bblock_eq_test_correct: wlp. +Hint Resolve bblock_simu_test_correct: wlp. (* Coerce bblock_eq_test into a pure function (this is a little unsafe like all oracles in CompCert). *) Import UnsafeImpure. -Definition pure_bblock_eq_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_eq_test verb p1 p2). +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). -Theorem pure_bblock_eq_test_correct verb p1 p2: - forall ge fn, Ge = Genv ge fn -> - pure_bblock_eq_test verb p1 p2 = true -> Asmblockgenproof0.bblock_equiv ge fn p1 p2. +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: Ge = Genv ge fn -> pure_bblock_simu_test verb p1 p2 = true -> bblock_simu ge fn p1 p2. Proof. - intros; unfold pure_bblock_eq_test. intros; eapply bblock_eq_test_correct; eauto. + intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. Qed. -Definition bblock_equivb: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_eq_test true. +Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Definition bblock_equiv_eq := pure_bblock_eq_test_correct true. +Lemma bblock_simub_correct p1 p2 ge fn: Ge = Genv ge fn -> bblock_simub p1 p2 = true -> bblock_simu ge fn p1 p2. +Proof. + eapply (pure_bblock_simu_test_correct true). +Qed. End SECT_BBLOCK_EQUIV. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index ecd40f5c..15cb4c48 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -211,7 +211,7 @@ Qed. Definition verify_schedule (bb bb' : bblock) : res unit := - match (bblock_equivb bb bb') with + match bblock_simub bb bb' with | true => OK tt | false => Error (msg "PostpassScheduling.verify_schedule") end. @@ -230,7 +230,7 @@ Lemma verify_schedule_no_header: forall bb bb', verify_schedule (no_header bb) bb' = verify_schedule bb bb'. Proof. - intros. unfold verify_schedule. unfold bblock_equivb. unfold pure_bblock_eq_test. unfold bblock_eq_test. rewrite trans_block_noheader_inv. + intros. unfold verify_schedule. unfold bblock_simub. unfold pure_bblock_simu_test, bblock_simu_test. rewrite trans_block_noheader_inv. reflexivity. Qed. @@ -240,7 +240,7 @@ Lemma stick_header_verify_schedule: stick_header hd bb' = hbb' -> verify_schedule bb bb' = verify_schedule bb hbb'. Proof. - intros. unfold verify_schedule. unfold bblock_equivb. unfold pure_bblock_eq_test. unfold bblock_eq_test. + intros. unfold verify_schedule. unfold bblock_simub, pure_bblock_simu_test, bblock_simu_test. rewrite <- H. rewrite trans_block_header_inv. reflexivity. Qed. @@ -429,15 +429,15 @@ Lemma verified_schedule_nob_correct: verified_schedule_nob bb = OK lbb -> exists tbb, concat_all lbb = OK tbb - /\ bblock_equiv ge f bb tbb. + /\ 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_equiv_eq; eauto. unfold verify_schedule in EQ0. unfold bblock_equivb in EQ0. - destruct (pure_bblock_eq_test true _ _); auto; try discriminate. + eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ0. + destruct (bblock_simub _ _); auto; try discriminate. Qed. Theorem verified_schedule_correct: @@ -445,7 +445,7 @@ Theorem verified_schedule_correct: verified_schedule bb = OK lbb -> exists tbb, concat_all lbb = OK tbb - /\ bblock_equiv ge f bb tbb. + /\ 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). diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f470ef8a..5d4fc881 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -741,7 +741,7 @@ Proof. eapply transf_function_no_overflow; eauto. erewrite transf_exec_bblock in H2; eauto. - inv BBEQ. rewrite H3 in H2. + unfold bblock_simu in BBEQ. rewrite BBEQ in H2; try congruence. exists (State rs' m'). split; try (constructor; auto). eapply transf_step_simu; eauto. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index a8da1cf1..e0780b9d 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -21,11 +21,10 @@ Module AB:=Asmvliw. Hint Extern 2 (_ <> _) => congruence: asmgen. -Inductive bblock_equiv (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - | bblock_equiv_intro: - (forall rs m, - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m) -> - bblock_equiv ge f bb bb'. +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. Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. -- cgit From 89a0a0e4acc6ea895a3eb702be88caf42c7096f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 May 2019 18:48:24 +0200 Subject: gain d'un cycle au moment du freeframe (passer au ret dans le même bundle) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b928a48e..1774b102 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -518,7 +518,12 @@ Definition unfold_exit (oc: option control) := | Some c => control_to_instruction c :: nil end. -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ unfold_body (body b) ++ unfold_exit (exit b) ++ Psemi :: nil. +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 -- cgit From 270001bc0bfa6e8e98362bdbdf7ff93e2670b1fa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 May 2019 19:01:55 +0200 Subject: put the get ra in same bundle as allocframe --- mppa_k1c/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 94846793..58cfa4c8 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -462,7 +462,7 @@ let expand_instruction instr = let below = Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; expand_storeind_ptr Asmvliw.GPR17 stack_pointer (Ptrofs.add ofs below); - emit Psemi; + (* DM we don't need it emit Psemi; *) vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> -- cgit From e1ae915f648df0137d0f183f3b992583528184a7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 May 2019 19:23:28 +0200 Subject: fix linking bug (my fault) --- mppa_k1c/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 58cfa4c8..db0ddd29 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -461,7 +461,7 @@ let expand_instruction instr = end else begin let below = Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; - expand_storeind_ptr Asmvliw.GPR17 stack_pointer (Ptrofs.add ofs below); + expand_storeind_ptr stack_pointer stack_pointer (Ptrofs.add ofs below); (* DM we don't need it emit Psemi; *) vararg_start_ofs := None end -- cgit From 0b99415251e56c64adb5caeec8f7c9c4f77ac926 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 7 May 2019 22:32:13 +0200 Subject: generalize bblock_equiv into bblock_simu (abstract_bb) --- mppa_k1c/Asmblockdeps.v | 39 ++++++++++------------ mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 22 ++++++------- mppa_k1c/abstractbb/DepTreeTheory.v | 6 ++-- mppa_k1c/abstractbb/ImpDep.v | 42 ++++++++++++------------ mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 15 ++------- mppa_k1c/abstractbb/Parallelizability.v | 8 ++--- 6 files changed, 59 insertions(+), 73 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c6207627..eb3900d5 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1300,7 +1300,7 @@ Local Hint Resolve trans_state_match. Lemma bblock_simu_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> - L.bblock_equiv Ge (trans_block p1) (trans_block p2) -> + L.bblock_simu Ge (trans_block p1) (trans_block p2) -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. @@ -1308,21 +1308,16 @@ Proof. 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. - remember (exec_bblock ge fn p1 rs m) as exp1. - destruct exp1. - + (* Next *) - intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. - destruct H2 as (m2' & H2 & H4). rewrite H2 in H3. - destruct (exec_bblock ge fn p2 rs m); simpl in H3. - * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. - cutrewrite (rs0=rs1). - - cutrewrite (m0=m1); auto. congruence. - - apply functional_extensionality. intros r. - generalize (H0 r). intros Hr. congruence. - * discriminate. - + intros MO MO2. remember (trans_state (State rs m)) as s1. inversion MO2. clear MO2. unfold exec in *. - rewrite H0 in H2. clear H0. destruct (exec_bblock ge fn p2 rs m); auto. rewrite H2 in MO. unfold match_outcome in MO. - destruct MO as (? & ? & ?). discriminate. + 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. + destruct (exec_bblock ge fn p2 rs m); simpl in H3. + * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. + cutrewrite (rs0=rs1). + - cutrewrite (m0=m1); auto. congruence. + - apply functional_extensionality. intros r. + generalize (H0 r). intros Hr. congruence. + * discriminate. Qed. Definition gpreg_name (gpr: gpreg) := @@ -1600,11 +1595,11 @@ Definition string_of_op (op: P.op): ?? pstring := Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then - IDT.verb_bblock_eq_test string_of_name string_of_op (trans_block p1) (trans_block p2) + IDT.verb_bblock_simu_test string_of_name string_of_op (trans_block p1) (trans_block p2) else - IDT.bblock_eq_test (trans_block p1) (trans_block p2). + IDT.bblock_simu_test (trans_block p1) (trans_block p2). -Local Hint Resolve IDT.bblock_eq_test_correct bblock_simu_reduce IDT.verb_bblock_eq_test_correct: wlp. +Local Hint Resolve IDT.bblock_simu_test_correct bblock_simu_reduce IDT.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. @@ -1613,13 +1608,13 @@ Proof. Qed. Hint Resolve bblock_simu_test_correct: wlp. -(* Coerce bblock_eq_test into a pure function (this is a little unsafe like all oracles in CompCert). *) +(* Coerce bblock_simu_test into a pure function (this is a little unsafe like all oracles in CompCert). *) Import UnsafeImpure. Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: Ge = Genv ge fn -> pure_bblock_simu_test verb p1 p2 = true -> bblock_simu ge fn p1 p2. +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. Proof. intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. @@ -1627,7 +1622,7 @@ 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 -> bblock_simu ge fn p1 p2. +Lemma bblock_simub_correct p1 p2 ge fn: Ge = Genv ge fn -> bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). Qed. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index d1950209..618f3ebe 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -140,9 +140,9 @@ Proof. Qed. -(** A small theory of bblockram equality *) +(** A small theory of bblock equality *) -(* equalities on bblockram outputs *) +(* equalities on bblock outputs *) Definition res_eq (om1 om2: option mem): Prop := match om1 with | Some m1 => exists m2, om2 = Some m2 /\ forall x, m1 x = m2 x @@ -163,10 +163,10 @@ Proof. - intros; erewrite IHe, IHe0; auto. Qed. -Definition bblock_equiv (p1 p2: bblock): Prop - := forall m, res_eq (run p1 m) (run p2 m). +Definition bblock_simu (p1 p2: bblock): Prop + := forall m, (run p1 m) <> None -> res_eq (run p1 m) (run p2 m). -Lemma alt_inst_equiv_refl i old1 old2: +Lemma inst_equiv_refl i old1 old2: (forall x, old1 x = old2 x) -> forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (inst_run i m1 old1) (inst_run i m2 old2). @@ -178,10 +178,10 @@ Proof. unfold assign; intro y. destruct (R.eq_dec x y); auto. Qed. -Lemma alt_bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). +Lemma bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). Proof. induction p as [ | i p']; simpl; eauto. - intros m1 m2 H; lapply (alt_inst_equiv_refl i m1 m2); auto. + intros m1 m2 H; lapply (inst_equiv_refl i m1 m2); auto. intros X; lapply (X m1 m2); auto; clear X. destruct (inst_run i m1 m1); simpl. - intros [m3 [H1 H2]]; rewrite H1; simpl; auto. @@ -205,11 +205,11 @@ Proof. - intro; subst; simpl; auto. Qed. -Lemma bblock_equiv_alt p1 p2: bblock_equiv p1 p2 <-> (forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p1 m1) (run p2 m2)). +Lemma bblock_simu_alt p1 p2: bblock_simu p1 p2 <-> (forall m1 m2, (forall x, m1 x = m2 x) -> (run p1 m1)<>None -> res_eq (run p1 m1) (run p2 m2)). Proof. - unfold bblock_equiv; intuition. - intros; eapply res_eq_trans. eapply alt_bblock_equiv_refl; eauto. - eauto. + unfold bblock_simu; intuition. + intros; eapply res_eq_trans. eauto. + eapply bblock_equiv_refl; eauto. Qed. diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index bfe79d42..bf45d11a 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -352,11 +352,11 @@ Proof. Qed. -Theorem bblock_deps_equiv p1 p2: +Theorem bblock_deps_simu p1 p2: (forall x, deps_get (bblock_deps p1) x = deps_get (bblock_deps p2) x) - -> bblock_equiv ge p1 p2. + -> bblock_simu ge p1 p2. Proof. - intros H m2. + intros H m2 DONTFAIL. remember (run ge p1 m2) as om1. destruct om1; simpl. + apply bblock_deps_Some_correct2. diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index a4dd12eb..2e2ad40f 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -385,7 +385,7 @@ Hypothesis hco_list_correct: hCons_spec hco_list. Variable print_error_end: hdeps -> hdeps -> ?? unit. Variable print_error: pstring -> ?? unit. -Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := +Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := 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 ;; @@ -398,23 +398,23 @@ Program Definition g_bblock_eq_test (p1 p2: bblock): ?? bool := CATCH_FAIL s, _ => print_error s;; RET false - ENSURE (fun b => b=true -> forall ge, bblock_equiv ge p1 p2));; + ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; RET (`r). Obligation 1. destruct hco_tree_correct as [X1 X2], hco_list_correct as [Y1 Y2]. constructor 1; wlp_simplify; try congruence. - apply bblock_deps_equiv; auto. + apply bblock_deps_simu; auto. intros; rewrite <- H, <- H0. apply pdeps_get_intro. auto. Qed. -Theorem g_bblock_eq_test_correct p1 p2: - WHEN g_bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. +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 exta; simpl in * |- *; auto. Qed. -Global Opaque g_bblock_eq_test. +Global Opaque g_bblock_simu_test. End Prog_Eq_Gen. @@ -424,7 +424,7 @@ Definition skip (_:unit): ?? unit := RET tt. Definition no_dbg (_:R.t): ?? option pstring := RET None. -Definition msg_prefix: pstring := "*** ERROR INFO from bblock_eq_test: ". +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". @@ -438,11 +438,11 @@ Definition print_error (log: logger unit) (s:pstring): ?? unit println (msg_prefix +; msg_number +; n +; " -- " +; s). -Program Definition bblock_eq_test (p1 p2: bblock): ?? bool := +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_eq_test no_dbg no_dbg skip (log_insert log) hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. + g_bblock_simu_test no_dbg no_dbg skip (log_insert log) hco_tree _ hco_list _ print_error_end (print_error log) p1 p2. Obligation 1. generalize (hCons_correct _ _ _ _ H0); clear H0. constructor 1; wlp_simplify. @@ -452,18 +452,18 @@ Obligation 2. constructor 1; wlp_simplify. Qed. -Local Hint Resolve g_bblock_eq_test_correct. +Local Hint Resolve g_bblock_simu_test_correct. -Theorem bblock_eq_test_correct p1 p2: - WHEN bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. +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_eq_test. +Global Opaque bblock_simu_test. -(** This is only to print info on each bblock_eq_test run **) +(** This is only to print info on each bblock_simu_test run **) Section Verbose_version. Variable string_of_name: R.t -> ?? pstring. @@ -689,13 +689,13 @@ Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing lis next_log hcl s ). -Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := +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_eq_test + DO result1 <~ g_bblock_simu_test (log_debug log1) simple_debug (hlog log1 hco_tree hco_list) @@ -713,7 +713,7 @@ Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := 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_eq_test + DO result2 <~ g_bblock_simu_test (log_debug log1) simple_debug (hlog log1 hco_tree hco_list) @@ -725,7 +725,7 @@ Program Definition verb_bblock_eq_test (p1 p2: bblock): ?? bool := p2 p1;; if result2 then ( - println (msg_prefix +; " OOops - symmetry violation in bblock_eq_test => this is a bug of bblock_eq_test ??");; + println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; RET false ) else RET false . @@ -746,12 +746,12 @@ Obligation 4. constructor 1; wlp_simplify. Qed. -Theorem verb_bblock_eq_test_correct p1 p2: - WHEN verb_bblock_eq_test p1 p2 ~> b THEN b=true -> forall ge, bblock_equiv ge p1 p2. +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_eq_test. +Global Opaque verb_bblock_simu_test. End Verbose_version. diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml index 0e5cf434..33c3c842 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -53,14 +53,6 @@ let memo_int2pos: int -> int -> BinNums.positive Hashtbl.add t i pi; pi in find;; - -(* -let string_coq2caml: char list -> string - = fun l -> - let buf = Buffer.create (List.length l) in - List.iter (fun c -> Buffer.add_char buf c) l; - Buffer.contents buf;; -*) let new_exit_observer: (unit -> unit) -> (unit -> unit) ref = fun f -> @@ -123,8 +115,8 @@ let zTr: BinNums.coq_Z -> int let ten = BinNums.Zpos (BinNums.Coq_xO (BinNums.Coq_xI (BinNums.Coq_xO BinNums.Coq_xH))) let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring -= let (q,r) = BinInt.Z.pos_div_eucl p ten in - let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in += let (q,r) = BinInt.Z.pos_div_eucl p ten in + let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in match q with | BinNums.Z0 -> acc0 | BinNums.Zpos p0 -> string_of_pos p0 acc0 @@ -134,7 +126,7 @@ let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring let string_of_Z_debug: BinNums.coq_Z -> pstring = fun p -> CamlStr (string_of_int (zTr p)) *) - + let string_of_Z: BinNums.coq_Z -> pstring = function | BinNums.Z0 -> CamlStr "0" @@ -148,4 +140,3 @@ let timer ((f:'a -> 'b), (x:'a)) : 'b = let rt = (Unix.times()).Unix.tms_utime -. itime in Printf.printf "time = %f\n" rt; r - diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index eae7b672..d1971e57 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -91,18 +91,18 @@ Proof. intros; destruct (inst_prun _ _ _); simpl; auto. Qed. -Lemma prun_iw_app_None p1 m1 old p2: +Lemma prun_iw_app_None p1: forall m1 old p2, prun_iw p1 m1 old = None -> prun_iw (p1++p2) m1 old = None. Proof. - intros H; rewrite prun_iw_app. rewrite H; auto. + intros m1 old p2 H; rewrite prun_iw_app. rewrite H; auto. Qed. -Lemma prun_iw_app_Some p1 m1 old m2 p2: +Lemma prun_iw_app_Some p1: forall m1 old m2 p2, prun_iw p1 m1 old = Some m2 -> prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. Proof. - intros H; rewrite prun_iw_app. rewrite H; auto. + intros m1 old m2 p2 H; rewrite prun_iw_app. rewrite H; auto. Qed. End PARALLEL. -- cgit From 4d608532aaeccec5a07a3c378682868b85dcbeec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 May 2019 13:19:08 +0200 Subject: simplification d'un code moche pour les variables thread-local --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index a2318469..d92e55ac 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -195,7 +195,7 @@ module Target (*: TARGET*) = fprintf oc " make %a = %s\n" ireg r (extern_atom id) end else begin if (extern_atom id) = "_impure_thread_data" then begin - fprintf oc " make %a = @tprel(%a)\n;;\n addd %a = %a, $r13\n" ireg r symbol_offset (id, ofs) ireg r ireg r + fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) end else begin fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) end -- cgit From 202a0a0a32bbddaa02ca429a4c1e6c74d1033aab Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 May 2019 14:12:43 +0200 Subject: structure copy through 4 byte registers instead of 1 --- mppa_k1c/Asmexpand.ml | 71 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 24 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index db0ddd29..55585905 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -23,7 +23,6 @@ open Asm open Asmexpandaux open AST open Camlcoq -open !Integers exception Error of string @@ -141,26 +140,50 @@ let get_builtin_arg dst arg = | BA_splitlong _ -> failwith "get_builtin_arg: BA_splitlong" | BA_addptr _ -> failwith "get_builtin_arg: BA_addptr";; +let memcpy_by_doubleword = true + (* FIXME DMonniaux this is really suboptimal (byte per byte) *) let expand_builtin_memcpy_big sz al src dst = assert (sz > Z.zero); let dstptr = Asmvliw.GPR62 and srcptr = Asmvliw.GPR63 - and tmpbuf = Asmvliw.GPR61 in + and tmpbuf = Asmvliw.GPR61 + and caml_sz = camlint64_of_coqint sz in get_builtin_arg dstptr dst; get_builtin_arg srcptr src; - emit (Pmake (tmpbuf, sz)); - emit Psemi; - let lbl = new_label() in - emit (Ploopdo (tmpbuf, lbl)); - emit Psemi; - emit (Plb (tmpbuf, srcptr, AOff Z.zero)); - emit (Paddil (srcptr, srcptr, Z.one)); - emit Psemi; - emit (Psb (tmpbuf, dstptr, AOff Z.zero)); - emit (Paddil (dstptr, dstptr, Z.one)); - emit Psemi; - emit (Plabel lbl);; + let caml_sz_div8 = Int64.shift_right caml_sz 3 + and eight = coqint_of_camlint64 8L in + if memcpy_by_doubleword && (Int64.shift_left caml_sz_div8 3) = caml_sz + then + begin + emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div8))); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Pld (tmpbuf, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, eight)); + emit Psemi; + emit (Psd (tmpbuf, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, eight)); + emit Psemi; + emit (Plabel lbl) + end + else + begin + emit (Pmake (tmpbuf, sz)); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Plb (tmpbuf, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, Z.one)); + emit Psemi; + emit (Psb (tmpbuf, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, Z.one)); + emit Psemi; + emit (Plabel lbl); + end;; let expand_builtin_memcpy sz al args = match args with @@ -185,7 +208,7 @@ let expand_builtin_vload_common chunk base ofs res = | Mint64, BR(Asmvliw.IR res) -> emit (Pld (res, base, AOff ofs)) | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> - let ofs' = Ptrofs.add ofs _4 in + 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')) @@ -223,7 +246,7 @@ let expand_builtin_vstore_common chunk base ofs src = | Mint64, BA(Asmvliw.IR src) -> emit (Psd (src, base, AOff ofs)) | Mint64, BA_splitlong(BA(Asmvliw.IR src1), BA(Asmvliw.IR src2)) -> - let ofs' = Ptrofs.add ofs _4 in + let ofs' = Integers.Ptrofs.add ofs _4 in emit (Psw (src2, base, AOff ofs)); emit (Psw (src1, base, AOff ofs')) | Mfloat32, BA(Asmvliw.IR src) -> @@ -267,7 +290,7 @@ let save_arguments first_reg base_ofs = let open Asmvliw in expand_storeind_ptr int_param_regs.(i) GPR12 - (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))); + (Integers.Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))); emit Psemi end done @@ -278,9 +301,9 @@ match !vararg_start_ofs with | None -> invalid_arg "Fatal error: va_start used in non-vararg function" | Some ofs -> - expand_addptrofs Asmvliw.GPR32 stack_pointer (Ptrofs.repr ofs); + expand_addptrofs Asmvliw.GPR32 stack_pointer (Integers.Ptrofs.repr ofs); emit Psemi; - expand_storeind_ptr Asmvliw.GPR32 r Ptrofs.zero + expand_storeind_ptr Asmvliw.GPR32 r Integers.Ptrofs.zero (* Auxiliary for 64-bit integer arithmetic built-ins. They expand to two instructions, one computing the low 32 bits of the result, @@ -449,7 +472,7 @@ let expand_instruction instr = let n = arguments_size sg in let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.neg full_sz)); + expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.neg full_sz)); emit Psemi; expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; emit Psemi; @@ -459,9 +482,9 @@ let expand_instruction instr = vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin - let below = Ptrofs.repr (Z.neg sz) in + let below = Integers.Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; - expand_storeind_ptr stack_pointer stack_pointer (Ptrofs.add ofs below); + 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 @@ -472,7 +495,7 @@ let expand_instruction instr = let n = arguments_size sg in if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) end else 0 in - expand_addptrofs stack_pointer stack_pointer (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) (*| Pseqw(rd, rs1, rs2) -> (* emulate based on the fact that x == 0 iff x assert Archi.ptr64; - emit (Paddiw (rd, rs, Int.zero)) (* 32-bit sign extension *) + emit (Paddiw (rd, rs, Integers.Int.zero)) (* 32-bit sign extension *) (*| Pjal_r(r, sg) -> fixup_call sg; emit instr -- cgit From 812efcd97046d6813c88f34b1b64aefae6d7e08d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 May 2019 14:46:36 +0200 Subject: slightly improved memcpy --- mppa_k1c/Asmexpand.ml | 35 +++++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 55585905..98c60f42 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -156,18 +156,29 @@ let expand_builtin_memcpy_big sz al src dst = if memcpy_by_doubleword && (Int64.shift_left caml_sz_div8 3) = caml_sz then begin - emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div8))); - emit Psemi; - let lbl = new_label() in - emit (Ploopdo (tmpbuf, lbl)); - emit Psemi; - emit (Pld (tmpbuf, srcptr, AOff Z.zero)); - emit (Paddil (srcptr, srcptr, eight)); - emit Psemi; - emit (Psd (tmpbuf, dstptr, AOff Z.zero)); - emit (Paddil (dstptr, dstptr, eight)); - emit Psemi; - emit (Plabel lbl) + if caml_sz_div8 >= 2L + then + begin + emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div8))); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Pld (tmpbuf, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, eight)); + emit Psemi; + emit (Psd (tmpbuf, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, eight)); + emit Psemi; + emit (Plabel lbl) + end + else + begin + emit (Pld (tmpbuf, srcptr, AOff Z.zero)); + emit Psemi; + emit (Psd (tmpbuf, dstptr, AOff Z.zero)); + emit Psemi; + end end else begin -- cgit From eaca012247ecd3a4a764ab24857cae150ca53a5d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 May 2019 15:10:57 +0200 Subject: copy 16 by 16 --- mppa_k1c/Asmexpand.ml | 27 ++++++++++++++------------- mppa_k1c/Machregs.v | 2 +- 2 files changed, 15 insertions(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 98c60f42..f123d6ba 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -140,44 +140,45 @@ let get_builtin_arg dst arg = | BA_splitlong _ -> failwith "get_builtin_arg: BA_splitlong" | BA_addptr _ -> failwith "get_builtin_arg: BA_addptr";; -let memcpy_by_doubleword = true - +let smart_memcpy = true + (* FIXME DMonniaux this is really suboptimal (byte per byte) *) let expand_builtin_memcpy_big sz al src dst = assert (sz > Z.zero); let dstptr = Asmvliw.GPR62 and srcptr = Asmvliw.GPR63 and tmpbuf = Asmvliw.GPR61 + and tmpbuf2 = Asmvliw.R60R61 and caml_sz = camlint64_of_coqint sz in get_builtin_arg dstptr dst; get_builtin_arg srcptr src; - let caml_sz_div8 = Int64.shift_right caml_sz 3 - and eight = coqint_of_camlint64 8L in - if memcpy_by_doubleword && (Int64.shift_left caml_sz_div8 3) = caml_sz + let caml_sz_div16 = Int64.shift_right caml_sz 4 + and sixteen = coqint_of_camlint64 16L in + if smart_memcpy && (Int64.shift_left caml_sz_div16 4) = caml_sz then begin - if caml_sz_div8 >= 2L + if caml_sz_div16 >= 2L then begin - emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div8))); + emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div16))); emit Psemi; let lbl = new_label() in emit (Ploopdo (tmpbuf, lbl)); emit Psemi; - emit (Pld (tmpbuf, srcptr, AOff Z.zero)); - emit (Paddil (srcptr, srcptr, eight)); + emit (Plq (tmpbuf2, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, sixteen)); emit Psemi; - emit (Psd (tmpbuf, dstptr, AOff Z.zero)); - emit (Paddil (dstptr, dstptr, eight)); + emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, sixteen)); emit Psemi; emit (Plabel lbl) end else begin - emit (Pld (tmpbuf, srcptr, AOff Z.zero)); emit Psemi; - emit (Psd (tmpbuf, dstptr, AOff Z.zero)); + emit (Plq (tmpbuf2, srcptr, AOff Z.zero)); emit Psemi; + emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); end end else diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ee85fb1c..491ba006 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -167,7 +167,7 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | EF_memcpy sz al => R62 :: R63 :: R61 :: nil + | EF_memcpy sz al => R62 :: R63 :: R61 :: R60 :: nil | _ => nil end. -- cgit From 34ba2d51f07a5050529512e888f3d7d56e2b6739 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 May 2019 16:46:41 +0200 Subject: smart memcpy for arbitrary sizes --- mppa_k1c/Asmexpand.ml | 37 ++++++++++++++++++++++++++----------- mppa_k1c/Machregs.v | 5 ++++- 2 files changed, 30 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index f123d6ba..65dee6c7 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -154,10 +154,24 @@ let expand_builtin_memcpy_big sz al src dst = get_builtin_arg srcptr src; let caml_sz_div16 = Int64.shift_right caml_sz 4 and sixteen = coqint_of_camlint64 16L in - if smart_memcpy && (Int64.shift_left caml_sz_div16 4) = caml_sz + if smart_memcpy then + let remaining = ref caml_sz + and offset = ref 0L in + let cpy buf size load store = + (if !remaining >= size + then + let zofs = coqint_of_camlint64 !offset in + begin + emit Psemi; + emit (load buf srcptr (AOff zofs)); + emit Psemi; + emit (store buf dstptr (AOff zofs)); + remaining := Int64.sub !remaining size; + offset := Int64.add !offset size + end) in begin - if caml_sz_div16 >= 2L + (if caml_sz_div16 >= 2L then begin emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div16))); @@ -171,15 +185,16 @@ let expand_builtin_memcpy_big sz al src dst = emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); emit (Paddil (dstptr, dstptr, sixteen)); emit Psemi; - emit (Plabel lbl) - end - else - begin - emit Psemi; - emit (Plq (tmpbuf2, srcptr, AOff Z.zero)); - emit Psemi; - emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); - end + emit (Plabel lbl); + remaining := Int64.sub !remaining (Int64.shift_left caml_sz_div16 4) + 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)); + assert (!remaining = 0L) end else begin diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 491ba006..cd8c6606 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -167,7 +167,10 @@ Fixpoint destroyed_by_clobber (cl: list string): list mreg := Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | EF_memcpy sz al => R62 :: R63 :: R61 :: R60 :: nil + | EF_memcpy sz al => + if Z.leb sz 15 + then R62 :: R63 :: R61 :: nil + else R62 :: R63 :: R61 :: R60 :: nil | _ => nil end. -- cgit From 1bed3383fb21e7604320c7eb4c877ceded447efa Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 May 2019 16:59:04 +0200 Subject: Replacing tabs by spaces in TargetPrinter --- mppa_k1c/TargetPrinter.ml | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index d92e55ac..114297c9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -347,45 +347,45 @@ module Target (*: TARGET*) = | Pwfxm(n, dst) -> fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst | Pldu(dst, addr) -> - fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr + fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr | Plbzu(dst, addr) -> - fprintf oc " lbz.u %a = 0[%a]\n" ireg dst ireg addr + fprintf oc " lbz.u %a = 0[%a]\n" ireg dst ireg addr | Plhzu(dst, addr) -> - fprintf oc " lhz.u %a = 0[%a]\n" ireg dst ireg addr + fprintf oc " lhz.u %a = 0[%a]\n" ireg dst ireg addr | Plwzu(dst, addr) -> - fprintf oc " lwz.u %a = 0[%a]\n" ireg dst ireg addr + fprintf oc " lwz.u %a = 0[%a]\n" ireg dst ireg addr | Pawait -> - fprintf oc " await\n" + fprintf oc " await\n" | Psleep -> - fprintf oc " sleep\n" + fprintf oc " sleep\n" | Pstop -> - fprintf oc " stop\n" + fprintf oc " stop\n" | Pbarrier -> - fprintf oc " barrier\n" + fprintf oc " barrier\n" | Pfence -> - fprintf oc " fence\n" + fprintf oc " fence\n" | Pdinval -> - fprintf oc " dinval\n" + fprintf oc " dinval\n" | Pdinvall addr -> - fprintf oc " dinvall 0[%a]\n" ireg addr + fprintf oc " dinvall 0[%a]\n" ireg addr | Pdtouchl addr -> - fprintf oc " dtouchl 0[%a]\n" ireg addr + fprintf oc " dtouchl 0[%a]\n" ireg addr | Piinval -> - fprintf oc " iinval\n" + fprintf oc " iinval\n" | Piinvals addr -> - fprintf oc " iinvals 0[%a]\n" ireg addr + fprintf oc " iinvals 0[%a]\n" ireg addr | Pitouchl addr -> - fprintf oc " itouchl 0[%a]\n" ireg addr + fprintf oc " itouchl 0[%a]\n" ireg addr | Pdzerol addr -> - fprintf oc " dzerol 0[%a]\n" ireg 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 + fprintf oc " 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 + fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res | Palclrd(res, addr) -> - fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr + fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr | Palclrw(res, addr) -> - fprintf oc " alclrw %a = 0[%a]\n" ireg res ireg addr + fprintf oc " alclrw %a = 0[%a]\n" ireg res ireg addr | Pjumptable (idx_reg, tbl) -> let lbl = new_label() in (* jumptables := (lbl, tbl) :: !jumptables; *) -- cgit From 94daba603cfb3f3be26f4b7e7215bdd695e51179 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 May 2019 16:59:36 +0200 Subject: Exploiting immediate comparisons --- mppa_k1c/Asmblockgen.v | 20 ++++-- mppa_k1c/Asmblockgenproof1.v | 161 +++++++++++++++++++++++++++++++++++-------- 2 files changed, 145 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index dc55715a..f2292f9a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -135,10 +135,18 @@ Definition transl_comp (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. +Definition transl_compi + (c: comparison) (s: signedness) (r: ireg) (imm: int) (lbl: label) (k: code) : list instruction := + Pcompiw (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. + Definition transl_compl (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. +Definition transl_compil + (c: comparison) (s: signedness) (r: ireg) (imm: int64) (lbl: label) (k: code) : list instruction := + Pcompil (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. + Definition select_comp (n: int) (c: comparison) : option comparison := if Int.eq n Int.zero then match c with @@ -156,10 +164,10 @@ Definition transl_opt_compuimm match c with | Ceq => Pcbu BTweqz r1 lbl ::g k | Cne => Pcbu BTwnez r1 lbl ::g k - | _ => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + | _ => transl_compi c Unsigned r1 n lbl k end else - loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + transl_compi c Unsigned r1 n lbl k . (* Definition transl_opt_compuimm @@ -192,10 +200,10 @@ Definition transl_opt_compluimm match c with | Ceq => Pcbu BTdeqz r1 lbl ::g k | Cne => Pcbu BTdnez r1 lbl ::g k - | _ => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + | _ => transl_compil c Unsigned r1 n lbl k end else - loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + transl_compil c Unsigned r1 n lbl k . Definition transl_comp_float32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := @@ -239,7 +247,7 @@ Definition transl_cbranch OK (if Int.eq n Int.zero then Pcb (btest_for_cmpswz c) r1 lbl ::g k else - loadimm32 RTMP n ::g (transl_comp c Signed r1 RTMP lbl k) + transl_compi c Signed r1 n lbl k ) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; @@ -255,7 +263,7 @@ Definition transl_cbranch OK (if Int64.eq n Int64.zero then Pcb (btest_for_cmpsdz c) r1 lbl ::g k else - loadimm64 RTMP n ::g (transl_compl c Signed r1 RTMP lbl k) + transl_compil c Signed r1 n lbl k ) | Ccompf c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 19b1b1f1..86a0ff88 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -340,6 +340,35 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compi_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compi cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compi. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs#r1 (Vint n)) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + Lemma transl_compu_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', @@ -369,6 +398,35 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compui_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compi cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compi. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmpu_bool cmp rs#r1 (Vint n)) as cmpubool. + destruct cmp; simpl; unfold Val_cmpu; + rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + Lemma transl_compl_correct: forall cmp r1 r2 lbl k rs m tbb b, exists rs', @@ -399,6 +457,36 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compil_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compil cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compil. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs#r1 (Vlong n)) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val.cmpl; + rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + Lemma swap_comparison_cmpf_eq: forall v1 v2 cmp, (Val.cmpf cmp v1 v2) = (Val.cmpf (swap_comparison cmp) v2 v1). @@ -710,6 +798,35 @@ Proof. rewrite H0. simpl; auto. Qed. +Lemma transl_compilu_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compil cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compil. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmplu_bool cmp rs#r1 (Vlong n)) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + Lemma transl_opt_compuimm_correct: forall n cmp r1 lbl k rs m b tbb c, select_comp n cmp = Some c -> @@ -907,16 +1024,12 @@ Proof. unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (loadimm32_correct RTMP n); eauto. intros (rs' & A & B & C). - exploit (transl_comp_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + + exploit (transl_compi_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez RTMP lbl). split. - * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Signed x RTMP lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. + * constructor. eexact A'. * split; auto. - { apply C'; auto. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } + { apply C'; auto. } (* Ccompuimm *) - remember (select_comp n c0) as selcomp. destruct selcomp. @@ -926,22 +1039,18 @@ Proof. split. * apply A. * split; auto. apply C. apply EVAL'. - + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 RTMP n ::g transl_comp c0 Unsigned x RTMP lbl k). + + assert (transl_opt_compuimm n c0 x lbl k = transl_compi c0 Unsigned x n lbl k). { unfold transl_opt_compuimm. destruct (Int.eq n Int.zero) eqn:EQN. all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. all: discriminate. } rewrite H. clear H. - exploit (loadimm32_correct RTMP n); eauto. intros (rs' & A & B & C). - exploit (transl_compu_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exploit (transl_compui_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez RTMP lbl). split. - * constructor. apply exec_straight_trans - with (c2 := (transl_comp c0 Unsigned x RTMP lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. + * constructor. eexact A'. * split; auto. - { apply C'; auto. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } + { apply C'; auto. } (* Ccompl *) - exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). exists rs', (Pcb BTwnez RTMP lbl). @@ -970,16 +1079,12 @@ Proof. unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. destruct c0; simpl; auto; unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (loadimm64_correct RTMP n); eauto. intros (rs' & A & B & C). - exploit (transl_compl_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + + exploit (transl_compil_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez RTMP lbl). split. - * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Signed x RTMP lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. + * constructor. eexact A'. * split; auto. - { apply C'; auto. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } + { apply C'; auto. } (* Ccompluimm *) - remember (select_compl n c0) as selcomp. @@ -990,22 +1095,18 @@ Proof. split. * apply A. * split; eauto. (* apply C. apply EVAL'. *) - + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 RTMP n ::g transl_compl c0 Unsigned x RTMP lbl k). + + assert (transl_opt_compluimm n c0 x lbl k = transl_compil c0 Unsigned x n lbl k). { unfold transl_opt_compluimm. destruct (Int64.eq n Int64.zero) eqn:EQN. all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. all: discriminate. } rewrite H. clear H. - exploit (loadimm64_correct RTMP n); eauto. intros (rs' & A & B & C). - exploit (transl_complu_correct c0 x RTMP lbl); eauto. intros (rs'2 & A' & B' & C'). + exploit (transl_compilu_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). exists rs'2, (Pcb BTwnez RTMP lbl). split. - * constructor. apply exec_straight_trans - with (c2 := (transl_compl c0 Unsigned x RTMP lbl k)) (rs2 := rs') (m2 := m'). - eexact A. eexact A'. + * constructor. eexact A'. * split; auto. - { apply C'; auto. rewrite B, C; eauto with asmgen. } - { intros. rewrite B'; eauto with asmgen. } + { apply C'; auto. eapply Val_cmplu_bool_correct; eauto. } (* Ccompf *) - exploit (transl_compf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). -- cgit From c3d719b7ecd4bf2e1cfaee6e619f3ec8e3fe7e10 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 10 May 2019 14:22:40 +0200 Subject: Asmblockgen prologue is now 1 basicblock (instead of 3) --- mppa_k1c/Asmblockgen.v | 9 ++--- mppa_k1c/Asmblockgenproof.v | 80 +++++++++++++++++++++++++------------------- mppa_k1c/Asmblockgenproof1.v | 47 ++++++++++++-------------- 3 files changed, 72 insertions(+), 64 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f2292f9a..a4364051 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1113,10 +1113,11 @@ Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: end . -Definition make_prologue (f: Machblock.function) lb := - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b - Pget GPRA RA ::b - storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::b lb). +Program Definition make_prologue (f: Machblock.function) lb := + ({| header := nil; body := Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i + Pget GPRA RA ::i + storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::i nil; + exit := None |} :: lb). Definition transl_function (f: Machblock.function) := do lb <- transl_blocks f f.(Machblock.fn_code) true; diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 0233a3dc..c44ef3ff 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -17,6 +17,7 @@ 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. @@ -1100,7 +1101,7 @@ Proof. destruct ep eqn:EPeq. (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. congruence. + instantiate (2 := rs1). rewrite DXP; eauto. intros [rs2 [P [Q R]]]. eapply exec_straight_body in P. @@ -1121,8 +1122,8 @@ Proof. (* GPR11 does not contain parent *) + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. congruence. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. congruence. + 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. @@ -1593,6 +1594,12 @@ Proof. 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'), @@ -1648,55 +1655,58 @@ Proof. intros [m3' [P Q]]. (* Execution of function prologue *) monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) - set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b - Pget GPRA RA ::b - storeind_ptr GPRA SP (fn_retaddr_ofs f) ::b x0) in *. + set (tfbody := make_prologue f x0) in *. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) - (rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef)). + 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'). +(* 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'' GPRA = rs' GPRA). { subst. Simpl. } assert (rs' SP = rs2 SP). { apply V'; discriminate. } - assert (rs'' SP = rs' SP). { subst. Simpl. } - rewrite H4. rewrite H3. rewrite H6. rewrite H5. + rewrite H4. rewrite H3. (* change (rs' GPRA) with (rs0 RA). *) rewrite ATLR. change (rs2 SP) with sp. eexact P. - congruence. congruence. intros (rs3 & U & V). - exploit (exec_straight_through_singleinst); eauto. - intro W. - remember (nextblock _ rs3) as rs3'. - assert (EXEC_PROLOGUE: +(* 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'). - { change (fn_blocks tf) with tfbody; unfold tfbody. - apply exec_straight_blocks_step with rs2 m2'. - unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control. - rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. rewrite regset_same_assign. reflexivity. - reflexivity. - eapply exec_straight_blocks_trans. - - eexact W'. - - eexact W. } + 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. unfold make_prologue in g. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor. + 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. unfold make_prologue in g. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. + 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_nextblock. apply agree_set_other; auto with asmgen. + 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. @@ -1705,17 +1715,17 @@ Local Transparent destroyed_at_function_entry. intros. assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. 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. - auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen. + 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 Heqrs''. Simpl. - rewrite H4 by auto with asmgen. reflexivity. + rewrite H4 by auto with asmgen. reflexivity. discriminate. - (* external function *) inv MS. exploit functions_translated; eauto. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 86a0ff88..3c1162bd 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1969,13 +1969,12 @@ Qed. Lemma indexed_memory_access_correct: forall mk_instr base ofs k rs m, - base <> RTMP -> exists base' ofs' rs' ptr', exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m (mk_instr base' ofs' ::g k) rs' m /\ eval_offset ofs' = OK ptr' /\ Val.offset_ptr rs'#base' ptr' = Val.offset_ptr rs#base ofs - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. + /\ forall r, r <> PC -> rs'#r = rs#r. Proof. unfold indexed_memory_access; intros. (* destruct Archi.ptr64 eqn:SF. *) @@ -2021,13 +2020,12 @@ Lemma indexed_load_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset 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 -> - base <> RTMP -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m /\ rs'#rd = v - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. - intros until m; intros EXEC; intros until v; intros LOAD NOT31. + intros until m; intros EXEC; intros until v; intros LOAD. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. @@ -2042,20 +2040,18 @@ Lemma indexed_store_access_correct: exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> forall (base: ireg) ofs k (rs: regset) m', Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - base <> RTMP -> r1 <> RTMP -> exists rs', exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. + /\ forall r, r <> PC -> rs'#r = rs#r. Proof. - intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31'. - exploit indexed_memory_access_correct. instantiate (1 := base). eauto. + intros until m; intros EXEC; intros until m'; intros STORE. + exploit indexed_memory_access_correct. (* instantiate (1 := base). eauto. *) intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). econstructor; split. eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq. rewrite B, C, STORE. eauto. discriminate. - { intro. inv H. contradiction. } auto. Qed. @@ -2063,13 +2059,12 @@ Lemma loadind_correct: forall (base: ireg) ofs ty dst k c (rs: regset) m v, loadind base ofs ty dst k = OK c -> Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - base <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. + /\ forall r, r <> PC -> r <> preg_of dst -> rs'#r = rs#r. Proof. - intros until v; intros TR LOAD NOT31. + intros until v; intros TR LOAD. assert (A: exists mk_instr rd, preg_of dst = IR rd /\ c = indexed_memory_access mk_instr base ofs :: k @@ -2086,12 +2081,11 @@ Lemma storeind_correct: forall (base: ireg) ofs ty src k c (rs: regset) m m', storeind src base ofs ty k = OK c -> Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - base <> RTMP -> exists rs', exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. + /\ forall r, r <> PC -> rs'#r = rs#r. Proof. - intros until m'; intros TR STORE NOT31. + intros until m'; intros TR STORE. assert (A: exists mk_instr rr, preg_of src = IR rr /\ c = indexed_memory_access mk_instr base ofs :: k @@ -2102,7 +2096,6 @@ Proof. destruct A as (mk_instr & rr & rsEq & B & C). subst c. eapply indexed_store_access_correct; eauto with asmgen. congruence. - destruct rr; try discriminate. destruct src; try discriminate. Qed. Ltac bsimpl := unfold exec_bblock; simpl. @@ -2139,23 +2132,21 @@ Qed. Lemma loadind_ptr_correct: forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> - base <> RTMP -> exists rs', exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m /\ rs'#dst = v - /\ forall r, r <> PC -> r <> RTMP -> r <> dst -> rs'#r = rs#r. + /\ 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 H1. auto. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. auto. Qed. Lemma storeind_ptr_correct: forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - base <> RTMP -> src <> RTMP -> exists rs', exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. + /\ forall r, r <> PC -> rs'#r = rs#r. Proof. intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. intros. unfold Mptr. assert (Archi.ptr64 = true); auto. @@ -2174,7 +2165,10 @@ Proof. intros until v; intros TR EV. unfold transl_memory_access in TR; destruct addr; ArgsInv. - (* indexed *) - inv EV. apply indexed_memory_access_correct; eauto with asmgen. + inv EV. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). + eexists; eexists; eexists; eexists. split; try split; try split. + eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. + { intros. destruct r; rewrite RSEQ; auto. } - (* global *) simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; econstructor; split. constructor. apply exec_straight_one. simpl; eauto. auto. @@ -2193,7 +2187,11 @@ Proof. destruct (Genv.find_symbol ge i); discriminate. + simpl. rewrite Ptrofs.add_zero; auto. - (* stack *) - inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. + inv TR. inv EV. + exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). + eexists; eexists; eexists; eexists. split; try split; try split. + eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. + { intros. destruct r; rewrite RSEQ; auto. } Qed. Lemma transl_memory_access2_correct: @@ -2658,7 +2656,6 @@ Proof. exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPRA (Pset RA GPRA ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) rs tm). - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - - congruence. - intros (rs1 & A1 & B1 & C1). assert (agree ms (Vptr stk soff) rs1) as AG1. + destruct AG. -- cgit From 95b43cbcc4390d9058034b769ffa757c42d2a74f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 20:02:11 +0200 Subject: new instructions at asm level --- mppa_k1c/Asm.v | 24 ++++++++++++++ mppa_k1c/Asmblockdeps.v | 14 +++++++- mppa_k1c/Asmvliw.v | 54 ++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++ mppa_k1c/TargetPrinter.ml | 62 ++++++++++++++++++++++++++++++++---- 5 files changed, 157 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1774b102..6a4095da 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -182,7 +182,9 @@ Inductive instruction : Type := | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Psubxw (shift : Z) (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 *) @@ -197,9 +199,12 @@ Inductive instruction : Type := | 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 *) | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : Z) (rd rs1 rs2: ireg) (**r add long shift *) | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Psubxl (shift : Z) (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 *) @@ -214,6 +219,7 @@ Inductive instruction : Type := | 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 *) @@ -226,6 +232,9 @@ Inductive instruction : Type := | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : Z) (rd rs: ireg) (imm: int) (**r add imm word *) + | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Psubxiw (shift : Z) (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 *) @@ -249,6 +258,9 @@ Inductive instruction : Type := (** 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 : Z) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Psubxil (shift : Z) (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 *) @@ -338,7 +350,9 @@ Definition basic_to_instruction (b: basic) := | 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.Psubxw shift) rd rs1 rs2 => Psubxw 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 @@ -354,7 +368,9 @@ Definition basic_to_instruction (b: basic) := | 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.Psubxl shift) rd rs1 rs2 => Psubxl 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 @@ -379,6 +395,9 @@ Definition basic_to_instruction (b: basic) := (* 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.Psubiw rd rs imm => Psubiw rd rs imm + | PArithRRI32 (Asmvliw.Psubxiw shift) rd rs imm => Psubxiw 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 @@ -401,6 +420,9 @@ Definition basic_to_instruction (b: basic) := (* 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.Psubil rd rs imm => Psubil rd rs imm + | PArithRRI64 (Asmvliw.Psubxil shift) rd rs imm => Psubxil 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 @@ -414,6 +436,8 @@ Definition basic_to_instruction (b: basic) := (** 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.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index eb3900d5..82062fab 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1405,12 +1405,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" + | Psubxw _ => "Psubxw" | Pmulw => "Pmulw" | Pandw => "Pandw" | Pnandw => "Pnandw" @@ -1425,7 +1427,9 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Psrxw => "Psrxw" | Psllw => "Psllw" | Paddl => "Paddl" + | Paddxl _ => "Paddxl" | Psubl => "Psubl" + | Psubxl _ => "Psubxl" | Pandl => "Pandl" | Pnandl => "Pnandl" | Porl => "Porl" @@ -1451,6 +1455,9 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" + | Psubiw => "Psubiw" + | Paddxiw _ => "Paddxiw" + | Psubxiw _ => "Psubxiw" | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" @@ -1475,6 +1482,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" + | Psubil => "Psubil" + | Paddxil _ => "Paddxil" + | Psubxil _ => "Psubxil" | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" @@ -1490,6 +1500,8 @@ 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" end. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3bef1a5c..e8ea4318 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -429,7 +429,9 @@ Inductive arith_name_rrr : Type := | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) - | Psubw (**r sub word *) + | Paddxw (shift : Z) (**r add shift *) + | Psubw (**r sub word word *) + | Psubxw (shift : Z) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -445,7 +447,9 @@ Inductive arith_name_rrr : Type := | Psllw (**r shift left logical word *) | Paddl (**r add long *) + | Paddxl (shift : Z) (**r add shift long *) | Psubl (**r sub long *) + | Psubxl (shift : Z) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -472,6 +476,9 @@ Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) + | Paddxiw (shift : Z) + | Psubiw (**r add imm word *) + | Psubxiw (shift : Z) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -495,6 +502,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 : Z) + | Psubil + | Psubxil (shift : Z) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -509,6 +519,8 @@ 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 *) . @@ -1055,12 +1067,33 @@ Definition arith_eval_rrr n v1 v2 := | Pfsbfw => Val.subfs v1 v2 | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 + + | Paddxw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.add v1 (Val.shl v2 (Vint (Int.repr shift))) + else Vundef + + | Paddxl shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.addl v1 (Val.shll v2 (Vint (Int.repr shift))) + else Vundef + + | Psubxw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.sub v1 (Val.shl v2 (Vint (Int.repr shift))) + else Vundef + + | Psubxl shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.subl v1 (Val.shll v2 (Vint (Int.repr shift))) + else Vundef 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) + | Psubiw => Val.sub v (Vint i) | Pmuliw => Val.mul v (Vint i) | Pandiw => Val.and v (Vint i) | Pnandiw => Val.notint (Val.and v (Vint i)) @@ -1079,12 +1112,21 @@ 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 => + if Z.leb shift 4 && Z.leb 1 shift + then Val.add (Vint i) (Val.shl v (Vint (Int.repr shift))) + else Vundef + | Psubxiw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.sub (Vint i) (Val.shl v (Vint (Int.repr shift))) + else Vundef 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) + | Psubil => Val.subl v (Vlong i) | Pmulil => Val.mull v (Vlong i) | Pandil => Val.andl v (Vlong i) | Pnandil => Val.notl (Val.andl v (Vlong i)) @@ -1094,12 +1136,22 @@ 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 => + if Z.leb shift 4 && Z.leb 1 shift + then Val.addl (Vlong i) (Val.shll v (Vint (Int.repr shift))) + else Vundef + | Psubxil shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.subl (Vlong i) (Val.shll v (Vint (Int.repr shift))) + else 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) + | Pmsubw => Val.sub v1 (Val.mul v2 v3) + | Pmsubl => Val.subl v1 (Val.mull v2 v3) | Pcmove bt => match cmp_for_btest bt with | (Some c, Int) => diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 39a14727..9b22cd01 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -61,7 +61,9 @@ let arith_rrr_str = function | Pfcompw ft -> "Pfcompw" | Pfcompl ft -> "Pfcompl" | Paddw -> "Paddw" + | Paddxw _ -> "Paddxw" | Psubw -> "Psubw" + | Psubxw _ -> "Psubxw" | Pmulw -> "Pmulw" | Pandw -> "Pandw" | Pnandw -> "Pnandw" @@ -76,7 +78,9 @@ let arith_rrr_str = function | Psrxw -> "Psrxw" | Psllw -> "Psllw" | Paddl -> "Paddl" + | Paddxl _ -> "Paddxl" | Psubl -> "Psubl" + | Psubxl _ -> "Psubxl" | Pandl -> "Pandl" | Pnandl -> "Pnandl" | Porl -> "Porl" @@ -100,6 +104,9 @@ let arith_rrr_str = function let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" + | Paddxiw _ -> "Paddxiw" + | Psubiw -> "Psubiw" + | Psubxiw _ -> "Psubxiw" | Pmuliw -> "Pmuliw" | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" @@ -122,6 +129,9 @@ let arith_rri32_str = function let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" + | Psubil -> "Psubil" + | Paddxil _ -> "Paddxil" + | Psubxil _ -> "Psubxil" | Pmulil -> "Pmulil" | Pandil -> "Pandil" | Pnandil -> "Pnandil" @@ -140,6 +150,8 @@ let arith_arr_str = function let arith_arrr_str = function | Pmaddw -> "Pmaddw" | Pmaddl -> "Pmaddl" + | Pmsubw -> "Pmsubw" + | Pmsubl -> "Pmsubl" | Pcmove _ -> "Pcmove" | Pcmoveu _ -> "Pcmoveu" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 114297c9..83d12da7 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -513,8 +513,18 @@ module Target (*: TARGET*) = | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxw (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Psubxw (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " subx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + 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) -> @@ -543,22 +553,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 + | Pmsubw (rd, rs1, rs2) -> + fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; + | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxl (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + 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; + | Psubxl (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + 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 @@ -576,6 +598,8 @@ 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 | Pfaddd (rd, rs1, rs2) -> fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -595,6 +619,18 @@ module Target (*: TARGET*) = 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 (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint imm + | Psubiw (rd, rs, imm) -> + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psubxiw (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + 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) -> @@ -640,6 +676,18 @@ 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 (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint imm + | Psubil (rd, rs, imm) -> + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psubxil (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + 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; -- cgit From e2ea45f5ba656254fa11bf3f355da67292c11f06 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 23:37:07 +0200 Subject: more integer Op --- mppa_k1c/Machregs.v | 5 +- mppa_k1c/NeedOp.v | 60 ++++++++++++++++++++ mppa_k1c/Op.v | 159 ++++++++++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/ValueAOp.v | 38 +++++++++++-- 4 files changed, 245 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index cd8c6606..6e0efe28 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -213,7 +213,10 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ + | Omadd | Omaddimm _ + | Omaddl | Omaddlimm _ + | Omsub | Omsubimm _ + | Omsubl | Omsublimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index c10f5c56..ced31758 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -42,8 +42,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 +77,19 @@ 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) + | Omsubimm n => op2 (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,6 +119,8 @@ 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) + | Omsublimm n => op2 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) @@ -229,6 +243,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, @@ -424,6 +458,14 @@ Proof. destruct nv; simpl; trivial. Qed. +Remark 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 needs_of_operation_sound: forall op args v nv args', eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> @@ -466,8 +508,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. +- repeat rewrite sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. +- repeat rewrite sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. + apply vagree_same. (* maddl *) - apply addl_sound; trivial. + apply mull_sound; trivial. + rewrite default_idem; trivial. + rewrite default_idem; trivial. + (* msubl *) +- apply subl_sound; trivial. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 5e80589b..b93a9fc3 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -66,6 +66,20 @@ Definition arg_type_of_condition0 (cond: condition0) := (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) +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 int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). + Inductive operation : Type := | Omove (**r [rd = r1] *) | Ointconst (n: int) (**r [rd] is set to the given integer constant *) @@ -79,8 +93,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] *) @@ -116,6 +135,8 @@ Inductive operation : Type := | 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] *) + | Omsubimm (n: int) (**r [rd = rd - r1 * imm] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -124,6 +145,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] *) @@ -160,6 +186,8 @@ 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] *) + | Omsublimm (n: int64) (**r [rd = rd - r1 * imm] *) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -235,9 +263,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 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. @@ -386,8 +419,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 shift, v1 :: v2 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) v2) + | Oaddximm shift n, v1 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) (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 (Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubximm shift n, v1 :: nil => Some (Val.sub (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) | 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 +461,8 @@ 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)) + | (Omsubimm n), v1::v2::nil => Some (Val.sub v1 (Val.mul v2 (Vint n))) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) @@ -431,8 +471,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 shift, v1 :: v2 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) v2) + | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) (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 (Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubxlimm shift n, v1 :: nil => Some (Val.subl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) | 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 +512,8 @@ 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)) + | (Omsublimm n), v1::v2::nil => Some (Val.subl v1 (Val.mull v2 (Vlong n))) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -583,8 +630,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 +672,8 @@ 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) + | Omsubimm _ => (Tint :: Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -628,6 +682,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,6 +723,8 @@ 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) + | Omsublimm _ => (Tlong :: Tlong :: nil, Tlong) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) @@ -736,6 +797,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 +848,17 @@ 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. + - apply type_add. (* 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 +914,11 @@ 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. + - apply type_sub. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -831,11 +929,16 @@ 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. + - apply type_addl. (* 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 +992,11 @@ 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, msublim *) + - apply type_subl. + - apply type_subl. (* negf, absf *) - destruct v0... - destruct v0... @@ -1359,9 +1463,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. + - apply Val.add_inject; trivial. + inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. (* 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 +1538,11 @@ 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. + - apply Val.sub_inject; trivial. + inv H2; inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1434,8 +1553,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. + - apply Val.addl_inject; auto. + 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. @@ -1500,6 +1632,11 @@ 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. + - apply Val.subl_inject; auto. + inv H4; inv H2; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 643cca0c..27faa33c 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -161,8 +161,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 (shl v1 (I (int_of_shift1_4 shift))) v2 + | Oaddximm shift n, v1::nil => add (shl v1 (I (int_of_shift1_4 shift))) (I n) | 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 +203,8 @@ 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) + | Omsubimm n, v1::v2::nil => sub v1 (mul v2 (I n)) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 @@ -205,8 +212,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 (shll v1 (I (int_of_shift1_4 shift))) v2 + | Oaddxlimm shift n, v1::nil => addl (shll v1 (I (int_of_shift1_4 shift))) (L n) | 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,6 +253,8 @@ 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) + | Omsublimm n, v1::v2::nil => subl v1 (mull v2 (L n)) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 @@ -360,11 +374,25 @@ Theorem eval_static_operation_sound: 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; - 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. + destruct op; try (InvHyps; eauto with va). + - destruct (propagate_float_constants tt); constructor. + - destruct (propagate_float_constants tt); constructor. + - rewrite Ptrofs.add_zero_l; eauto with va. + - (*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 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. (* 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. -- cgit From 295058286407ec6c4182f2b12b27608fc7d28f95 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 23:53:02 +0200 Subject: use shift 1-4 in backend --- mppa_k1c/Asm.v | 16 ++++++------- mppa_k1c/Asmvliw.v | 61 ++++++++++++++--------------------------------- mppa_k1c/ExtValues.v | 14 +++++++++++ mppa_k1c/Op.v | 14 ----------- mppa_k1c/TargetPrinter.ml | 54 +++++++++++++++++------------------------ 5 files changed, 62 insertions(+), 97 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 6a4095da..04f6969b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -182,9 +182,9 @@ Inductive instruction : Type := | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : Z) (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 *) - | Psubxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) + | Psubxw (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 *) @@ -202,9 +202,9 @@ Inductive instruction : Type := | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : Z) (rd rs1 rs2: ireg) (**r add long shift *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Psubxl (shift : Z) (rd rs1 rs2: ireg) (**r sub long shift *) + | Psubxl (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 *) @@ -232,9 +232,9 @@ Inductive instruction : Type := | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : Z) (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Psubxiw (shift : Z) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Psubxiw (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 *) @@ -258,9 +258,9 @@ Inductive instruction : Type := (** 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 : Z) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Psubxil (shift : Z) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Psubxil (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 *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e8ea4318..e332cedc 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -429,9 +429,9 @@ Inductive arith_name_rrr : Type := | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) - | Paddxw (shift : Z) (**r add shift *) + | Paddxw (shift : shift1_4) (**r add shift *) | Psubw (**r sub word word *) - | Psubxw (shift : Z) (**r sub shift word *) + | Psubxw (shift : shift1_4) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -447,9 +447,9 @@ Inductive arith_name_rrr : Type := | Psllw (**r shift left logical word *) | Paddl (**r add long *) - | Paddxl (shift : Z) (**r add shift long *) + | Paddxl (shift : shift1_4) (**r add shift long *) | Psubl (**r sub long *) - | Psubxl (shift : Z) (**r sub shift long *) + | Psubxl (shift : shift1_4) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -476,9 +476,9 @@ Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) - | Paddxiw (shift : Z) + | Paddxiw (shift : shift1_4) | Psubiw (**r add imm word *) - | Psubxiw (shift : Z) + | Psubxiw (shift : shift1_4) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -502,9 +502,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 : Z) + | Paddxil (shift : shift1_4) | Psubil - | Psubxil (shift : Z) + | Psubxil (shift : shift1_4) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -1068,25 +1068,12 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.add v1 (Val.shl v2 (Vint (Int.repr shift))) - else Vundef - - | Paddxl shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.addl v1 (Val.shll v2 (Vint (Int.repr shift))) - else Vundef - - | Psubxw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.sub v1 (Val.shl v2 (Vint (Int.repr shift))) - else Vundef - - | Psubxl shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.subl v1 (Val.shll v2 (Vint (Int.repr shift))) - else Vundef + | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + + | Psubxw shift => Val.sub v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + + | Psubxl shift => Val.subl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri32 n v i := @@ -1112,14 +1099,8 @@ 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 => - if Z.leb shift 4 && Z.leb 1 shift - then Val.add (Vint i) (Val.shl v (Vint (Int.repr shift))) - else Vundef - | Psubxiw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.sub (Vint i) (Val.shl v (Vint (Int.repr shift))) - else Vundef + | Paddxiw shift => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Psubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri64 n v i := @@ -1136,14 +1117,8 @@ 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 => - if Z.leb shift 4 && Z.leb 1 shift - then Val.addl (Vlong i) (Val.shll v (Vint (Int.repr shift))) - else Vundef - | Psubxil shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.subl (Vlong i) (Val.shll v (Vint (Int.repr shift))) - else Vundef + | Paddxil shift => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | Psubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 5d16b79c..1aa17458 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -2,6 +2,20 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +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 int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). + Definition is_bitfield stop start := (Z.leb start stop) && (Z.geb start Z.zero) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index b93a9fc3..4abd104e 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -66,20 +66,6 @@ Definition arg_type_of_condition0 (cond: condition0) := (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) -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 int_of_shift1_4 (x : shift1_4) := - Int.repr (z_of_shift1_4 x). - Inductive operation : Type := | Omove (**r [rd = r1] *) | Ointconst (n: int) (**r [rd] is set to the given integer constant *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 83d12da7..6a21e63d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -130,6 +130,12 @@ module Target (*: TARGET*) = | 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 @@ -513,17 +519,13 @@ module Target (*: TARGET*) = | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxw (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | 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 - | Psubxw (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " subx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxw (s14, rd, rs1, rs2) -> + fprintf oc " subx%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 @@ -558,17 +560,13 @@ module Target (*: TARGET*) = | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxl (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | 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 - | Psubxl (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxl (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 @@ -619,17 +617,13 @@ module Target (*: TARGET*) = 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 (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxiw (s14, rd, rs, imm) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Psubiw (rd, rs, imm) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psubxiw (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxiw (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 @@ -676,17 +670,13 @@ 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 (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxil (s14, rd, rs, imm) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Psubil (rd, rs, imm) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psubxil (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxil (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 -- cgit From d8d22519bff9414f973a1310cb32eb60e6695796 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:02:13 +0200 Subject: begin generating Prevsub etc. from Oxxx to Pxxx --- mppa_k1c/Asm.v | 24 ++++++++++++------------ mppa_k1c/Asmblockdeps.v | 12 ++++++------ mppa_k1c/Asmblockgen.v | 3 +++ mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmvliw.v | 24 ++++++++++++------------ mppa_k1c/PostpassSchedulingOracle.ml | 12 ++++++------ mppa_k1c/TargetPrinter.ml | 12 ++++++------ 7 files changed, 46 insertions(+), 43 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 04f6969b..e5f81fbb 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -184,7 +184,7 @@ Inductive instruction : Type := | 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 *) - | Psubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add 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 *) @@ -204,7 +204,7 @@ Inductive instruction : Type := | 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 *) - | Psubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | 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 *) @@ -233,8 +233,8 @@ Inductive instruction : Type := | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Psubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract 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 *) @@ -259,8 +259,8 @@ Inductive instruction : Type := | 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 *) - | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Psubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm 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 *) @@ -352,7 +352,7 @@ Definition basic_to_instruction (b: basic) := | 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.Psubxw shift) rd rs1 rs2 => Psubxw shift 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 @@ -370,7 +370,7 @@ Definition basic_to_instruction (b: basic) := | 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.Psubxl shift) rd rs1 rs2 => Psubxl shift 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 @@ -396,8 +396,8 @@ Definition basic_to_instruction (b: basic) := | 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.Psubiw rd rs imm => Psubiw rd rs imm - | PArithRRI32 (Asmvliw.Psubxiw shift) rd rs imm => Psubxiw 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 @@ -421,8 +421,8 @@ Definition basic_to_instruction (b: basic) := | 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.Psubil rd rs imm => Psubil rd rs imm - | PArithRRI64 (Asmvliw.Psubxil shift) rd rs imm => Psubxil 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 82062fab..616ec6db 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1412,7 +1412,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Paddw => "Paddw" | Paddxw _ => "Paddxw" | Psubw => "Psubw" - | Psubxw _ => "Psubxw" + | Prevsubxw _ => "Prevsubxw" | Pmulw => "Pmulw" | Pandw => "Pandw" | Pnandw => "Pnandw" @@ -1429,7 +1429,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Paddl => "Paddl" | Paddxl _ => "Paddxl" | Psubl => "Psubl" - | Psubxl _ => "Psubxl" + | Prevsubxl _ => "Prevsubxl" | Pandl => "Pandl" | Pnandl => "Pnandl" | Porl => "Porl" @@ -1455,9 +1455,9 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" - | Psubiw => "Psubiw" | Paddxiw _ => "Paddxiw" - | Psubxiw _ => "Psubxiw" + | Prevsubiw => "Prevsubiw" + | Prevsubxiw _ => "Prevsubxiw" | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" @@ -1482,9 +1482,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" - | Psubil => "Psubil" + | Prevsubil => "Prevsubil" | Paddxil _ => "Paddxil" - | Psubxil _ => "Psubxil" + | Prevsubxil _ => "Prevsubxil" | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f2292f9a..839d444d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -449,6 +449,9 @@ Definition transl_op | 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) | 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) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 86a0ff88..1569aedf 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1693,7 +1693,7 @@ Opaque Int.eq. 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. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e332cedc..2bf9115e 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -431,7 +431,7 @@ Inductive arith_name_rrr : Type := | Paddw (**r add word *) | Paddxw (shift : shift1_4) (**r add shift *) | Psubw (**r sub word word *) - | Psubxw (shift : shift1_4) (**r sub shift word *) + | Prevsubxw (shift : shift1_4) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -449,7 +449,7 @@ Inductive arith_name_rrr : Type := | Paddl (**r add long *) | Paddxl (shift : shift1_4) (**r add shift long *) | Psubl (**r sub long *) - | Psubxl (shift : shift1_4) (**r sub shift long *) + | Prevsubxl (shift : shift1_4) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -477,8 +477,8 @@ Inductive arith_name_rri32 : Type := | Paddiw (**r add imm word *) | Paddxiw (shift : shift1_4) - | Psubiw (**r add imm word *) - | Psubxiw (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 *) @@ -503,8 +503,8 @@ Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) | Paddxil (shift : shift1_4) - | Psubil - | Psubxil (shift : shift1_4) + | Prevsubil + | Prevsubxil (shift : shift1_4) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -1071,16 +1071,16 @@ Definition arith_eval_rrr n v1 v2 := | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) - | Psubxw shift => Val.sub v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) - | Psubxl shift => Val.subl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + | Prevsubxl shift => Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift))) 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) - | Psubiw => Val.sub 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)) @@ -1100,14 +1100,14 @@ Definition arith_eval_rri32 n v i := | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) | Paddxiw shift => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) - | Psubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Prevsubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) 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) - | Psubil => Val.subl 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)) @@ -1118,7 +1118,7 @@ Definition arith_eval_rri64 n v i := | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) | Paddxil shift => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) - | Psubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | Prevsubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9b22cd01..9dc1ab44 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -63,7 +63,7 @@ let arith_rrr_str = function | Paddw -> "Paddw" | Paddxw _ -> "Paddxw" | Psubw -> "Psubw" - | Psubxw _ -> "Psubxw" + | Prevsubxw _ -> "Psubxw" | Pmulw -> "Pmulw" | Pandw -> "Pandw" | Pnandw -> "Pnandw" @@ -80,7 +80,7 @@ let arith_rrr_str = function | Paddl -> "Paddl" | Paddxl _ -> "Paddxl" | Psubl -> "Psubl" - | Psubxl _ -> "Psubxl" + | Prevsubxl _ -> "Psubxl" | Pandl -> "Pandl" | Pnandl -> "Pnandl" | Porl -> "Porl" @@ -105,8 +105,8 @@ let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" | Paddxiw _ -> "Paddxiw" - | Psubiw -> "Psubiw" - | Psubxiw _ -> "Psubxiw" + | Prevsubiw -> "Psubiw" + | Prevsubxiw _ -> "Psubxiw" | Pmuliw -> "Pmuliw" | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" @@ -129,9 +129,9 @@ let arith_rri32_str = function let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" - | Psubil -> "Psubil" + | Prevsubil -> "Psubil" | Paddxil _ -> "Paddxil" - | Psubxil _ -> "Psubxil" + | Prevsubxil _ -> "Psubxil" | Pmulil -> "Pmulil" | Pandil -> "Pandil" | Pnandil -> "Pnandil" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 6a21e63d..2d870c01 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -524,7 +524,7 @@ module Target (*: TARGET*) = ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxw (s14, rd, rs1, rs2) -> + | Prevsubxw (s14, rd, rs1, rs2) -> fprintf oc " subx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> @@ -565,7 +565,7 @@ module Target (*: TARGET*) = ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxl (s14, rd, rs1, rs2) -> + | 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) -> @@ -620,9 +620,9 @@ module Target (*: TARGET*) = | Paddxiw (s14, rd, rs, imm) -> fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm - | Psubiw (rd, rs, imm) -> + | Prevsubiw (rd, rs, imm) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psubxiw (s14, rd, rs, 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) -> @@ -673,9 +673,9 @@ module Target (*: TARGET*) = | Paddxil (s14, rd, rs, imm) -> fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm - | Psubil (rd, rs, imm) -> + | Prevsubil (rd, rs, imm) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psubxil (s14, rd, rs, 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; -- cgit From d336d31434602b786bcaa89c8d91d2472d9cb3f5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:35:31 +0200 Subject: Oaddx -> P --- mppa_k1c/Asmblockgen.v | 6 ++++++ mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmvliw.v | 4 ++-- mppa_k1c/Op.v | 20 ++++++++++---------- mppa_k1c/ValueAOp.v | 37 +++++++++++++++++++++++++++++-------- 5 files changed, 48 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 839d444d..ef980894 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -443,6 +443,12 @@ 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) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs ::i k) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1569aedf..86a0ff88 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1693,7 +1693,7 @@ Opaque Int.eq. 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. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 2bf9115e..c1f21f8d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1068,8 +1068,8 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) - | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + | Paddxw shift => Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4abd104e..fb6c454c 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -405,8 +405,8 @@ 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 shift, v1 :: v2 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) v2) - | Oaddximm shift n, v1 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) (Vint n)) + | Oaddx shift, v1 :: v2 :: nil => Some (Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Oaddximm shift n, v1 :: nil => Some (Val.add (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) | 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) @@ -457,8 +457,8 @@ 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 shift, v1 :: v2 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) v2) - | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) (Vlong n)) + | Oaddxl shift, v1 :: v2 :: nil => Some (Val.addl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) | 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) @@ -836,7 +836,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_add. (* addx, addximm *) - apply type_add. - - apply type_add. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* neg, sub *) - destruct v0... - apply type_sub. @@ -917,7 +918,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_addl. (* addxl addxlimm *) - apply type_addl. - - apply type_addl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - destruct v0... - apply type_subl. @@ -1452,8 +1454,7 @@ Proof. (* addx, addximm *) - apply Val.add_inject; trivial. inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - apply Val.add_inject; trivial. - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; trivial. try destruct (Int.ltu _ _); simpl; auto. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. @@ -1543,8 +1544,7 @@ Proof. - apply Val.addl_inject; auto. inv H4; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. - - apply Val.addl_inject; auto. - inv H4; simpl; trivial. + - inv H4; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 27faa33c..00e8a1d8 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -161,8 +161,8 @@ 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 (shl v1 (I (int_of_shift1_4 shift))) v2 - | Oaddximm shift n, v1::nil => add (shl v1 (I (int_of_shift1_4 shift))) (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))) @@ -212,8 +212,8 @@ 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 (shll v1 (I (int_of_shift1_4 shift))) v2 - | Oaddxlimm shift n, v1::nil => addl (shll v1 (I (int_of_shift1_4 shift))) (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))) @@ -378,20 +378,41 @@ Proof. - 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 a1; destruct shift; reflexivity. + + eauto with va. + + destruct a1; 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. + + eauto with va. + + destruct a1; destruct shift; reflexivity. - 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). -- cgit From f3d9c333fb27b1afb733b7aa8dfc9e2b22b596aa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:41:20 +0200 Subject: more gen O -> P --- mppa_k1c/Asmblockgen.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ef980894..505d6c86 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -458,6 +458,12 @@ Definition transl_op | 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) -- cgit From 428af5f71a063962e53e4ab58eaa372ccc926394 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:47:39 +0200 Subject: more gen O -> P --- mppa_k1c/Asmblockgen.v | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 505d6c86..4cce7075 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -582,6 +582,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) -- cgit From ae22df3c5ef0a60527ea85b83bb71e8c95a6ab9c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 07:59:11 +0200 Subject: Pmsub compiled --- mppa_k1c/Asmblockgen.v | 12 ++++++++++++ mppa_k1c/ExtValues.v | 16 ++++++++++++++++ mppa_k1c/Machregs.v | 3 +-- mppa_k1c/NeedOp.v | 19 +------------------ mppa_k1c/Op.v | 14 +------------- mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++----- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 6 ++++++ mppa_k1c/ValueAOp.v | 2 -- 9 files changed, 48 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 4cce7075..7be83962 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -558,6 +558,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; @@ -686,6 +692,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) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 1aa17458..0d56fd1c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -131,3 +131,19 @@ Definition val_shrxl (v1 v2: val): val := else Vundef | _, _ => Vundef end. + +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. \ No newline at end of file diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 6e0efe28..db3dfe64 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -215,8 +215,7 @@ Definition two_address_op (op: operation) : bool := match op with | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ - | Omsub | Omsubimm _ - | Omsubl | Omsublimm _ + | Omsub | Omsubl | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index ced31758..5ba9851f 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -78,7 +78,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omadd => op3 (modarith nv) | Omaddimm n => op2 (modarith nv) | Omsub => op3 (modarith nv) - | Omsubimm n => op2 (modarith nv) | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocast32signed => op1 (default nv) @@ -120,7 +119,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omaddl => op3 (default nv) | Omaddlimm n => op2 (default nv) | Omsubl => op3 (default nv) - | Omsublimm n => op2 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) @@ -457,14 +455,6 @@ Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. Qed. - -Remark 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 needs_of_operation_sound: forall op args v nv args', @@ -508,19 +498,12 @@ 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. -- repeat rewrite sub_add_neg. - apply add_sound; trivial. - apply neg_sound; trivial. - rewrite modarith_idem. - apply mul_sound; - rewrite modarith_idem; trivial. -- repeat rewrite sub_add_neg. +- repeat rewrite ExtValues.sub_add_neg. apply add_sound; trivial. apply neg_sound; trivial. rewrite modarith_idem. apply mul_sound; rewrite modarith_idem; trivial. - apply vagree_same. (* maddl *) - apply addl_sound; trivial. apply mull_sound; trivial. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index fb6c454c..ac40c293 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -122,7 +122,6 @@ Inductive operation : Type := | Omadd (**r [rd = rd + r1 * r2] *) | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) | Omsub (**r [rd = rd - r1 * r2] *) - | Omsubimm (n: int) (**r [rd = rd - r1 * imm] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -173,7 +172,6 @@ Inductive operation : Type := | Omaddl (**r [rd = rd + r1 * r2] *) | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) | Omsubl (**r [rd = rd - r1 * r2] *) - | Omsublimm (n: int64) (**r [rd = rd - r1 * imm] *) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -448,7 +446,6 @@ Definition eval_operation | 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)) - | (Omsubimm n), v1::v2::nil => Some (Val.sub v1 (Val.mul v2 (Vint n))) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) @@ -499,7 +496,6 @@ Definition eval_operation | 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)) - | (Omsublimm n), v1::v2::nil => Some (Val.subl v1 (Val.mull v2 (Vlong n))) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -659,7 +655,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omadd => (Tint :: Tint :: Tint :: nil, Tint) | Omaddimm _ => (Tint :: Tint :: nil, Tint) | Omsub => (Tint :: Tint :: Tint :: nil, Tint) - | Omsubimm _ => (Tint :: Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -710,7 +705,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) - | Omsublimm _ => (Tlong :: Tlong :: nil, Tlong) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) @@ -905,7 +899,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_add. (* msub *) - apply type_sub. - - apply type_sub. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -982,8 +975,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* maddl, maddlim *) - apply type_addl. - apply type_addl. - (* msubl, msublim *) - - apply type_subl. + (* msubl *) - apply type_subl. (* negf, absf *) - destruct v0... @@ -1528,8 +1520,6 @@ Proof. (* msub *) - apply Val.sub_inject; auto. inv H3; inv H2; simpl; auto. - - apply Val.sub_inject; trivial. - inv H2; inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1621,8 +1611,6 @@ Proof. (* msubl, msublimm *) - apply Val.subl_inject; auto. inv H2; inv H3; inv H4; simpl; auto. - - apply Val.subl_inject; auto. - inv H4; inv H2; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9dc1ab44..f428fe49 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -464,7 +464,7 @@ type real_instruction = | 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 + | Maddw | Maddd | Msbfw | Msbfd | Cmoved | Make | Nop | Extfz | Extfs | Insf (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo @@ -505,6 +505,7 @@ let ab_inst_to_real = function | "Psllw" | "Pslliw" -> Sllw | "Proriw" -> Rorw | "Pmaddw" | "Pmaddiw" -> Maddw + | "Pmsubw" | "Pmsubiw" -> Msbfw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pnxorw" | "Pnxoriw" -> Nxorw @@ -514,7 +515,8 @@ let ab_inst_to_real = function | "Pnxorl" | "Pnxoril" -> Nxord | "Pandnl" | "Pandnil" -> Andnd | "Pornl" | "Pornil" -> Ornd - | "Pmaddl" -> Maddd + | "Pmaddl" | "Pmaddil" -> Maddd + | "Pmsubl" | "Pmsubil" -> Msbfd | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz @@ -608,10 +610,10 @@ 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 + | Mulw| Maddw | 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 | Maddd | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop @@ -644,7 +646,7 @@ let real_inst_to_latency = function | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved -> 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 diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6adcebe5..81e288cb 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -151,6 +151,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. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 9e2eec8b..17024826 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -251,6 +251,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. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 00e8a1d8..adc27010 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -204,7 +204,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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) - | Omsubimm n, v1::v2::nil => sub v1 (mul v2 (I n)) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 @@ -254,7 +253,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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) - | Omsublimm n, v1::v2::nil => subl v1 (mull v2 (L n)) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 -- cgit From 3ef3e6c78026cc1d5793ccb4e905a0232ec7bb4e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 10:21:59 +0200 Subject: generate multiply-sub long --- mppa_k1c/ExtValues.v | 33 ++++++++++++++++++++++++++++++++- mppa_k1c/SelectLong.vp | 6 +++++- mppa_k1c/SelectLongproof.v | 21 +++++++++++++++++++-- 3 files changed, 56 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 0d56fd1c..735d5c3c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -146,4 +146,35 @@ Proof. destruct x; destruct y; simpl; trivial. f_equal. apply Int.neg_mul_distr_r. -Qed. \ No newline at end of file +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. + diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 717b0120..b29b9712 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -118,6 +118,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 +229,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) := diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3b724c01..257c7fd9 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -208,6 +208,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 +388,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 +406,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)). -- cgit From 2c428ad4e0177756db2f6dfe56831b5a44f6de5c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 15:20:02 +0200 Subject: add with shift, beginning --- mppa_k1c/Asmvliw.v | 4 ++-- mppa_k1c/ExtValues.v | 24 ++++++++++++++++++++++++ mppa_k1c/Op.v | 7 ++++--- mppa_k1c/PostpassSchedulingOracle.ml | 9 ++++++--- mppa_k1c/SelectOp.vp | 10 +++++++++- mppa_k1c/SelectOpproof.v | 36 ++++++++++++++++++++++++++++++++++++ mppa_k1c/ValueAOp.v | 9 +++++---- 7 files changed, 86 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c1f21f8d..e1a7f916 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1068,7 +1068,7 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) + | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) @@ -1099,7 +1099,7 @@ 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 => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) | Prevsubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) end. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 735d5c3c..32d84b60 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -13,6 +13,28 @@ Definition z_of_shift1_4 (x : shift1_4) := | 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). @@ -178,3 +200,5 @@ Proof. apply Int64.neg_mul_distr_r. Qed. +Definition addx sh v1 v2 := + Val.add v2 (Val.shl v1 (Vint sh)). \ No newline at end of file diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index ac40c293..69620934 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -403,8 +403,8 @@ 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 shift, v1 :: v2 :: nil => Some (Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) - | Oaddximm shift n, v1 :: nil => Some (Val.add (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | 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) @@ -1446,7 +1446,8 @@ Proof. (* addx, addximm *) - apply Val.add_inject; trivial. inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - inv H4; simpl; trivial. 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. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f428fe49..3618969a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -466,6 +466,7 @@ type real_instruction = | 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 @@ -479,6 +480,8 @@ type real_instruction = let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw + | "Paddxw" | "Paddxiw" -> Addxw + | "Paddxl" | "Paddxil" -> Addxd | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd | "Pandw" | "Pandiw" -> Andw | "Pnandw" | "Pnandiw" -> Nandw @@ -585,12 +588,12 @@ let rec_to_usage r = and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw -> + | Nxorw | Andnw | Ornw | Addxw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved -> + | Nxord | Andnd | Ornd | Cmoved | Addxd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) @@ -643,7 +646,7 @@ let real_inst_to_latency = function | 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 + | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 81e288cb..ae9d64b9 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -114,6 +114,12 @@ Nondetfunction addimm (n: int) (e: expr) := | _ => Eop (Oaddimm n) (e ::: Enil) end. +Definition add_shlimm n e1 e2 := + 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. + Nondetfunction add (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 @@ -135,7 +141,9 @@ 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 | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 17024826..7b026bf5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -201,6 +201,37 @@ Proof. + TrivialExists. Qed. +Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n). +Proof. + red. + intros. + unfold add_shlimm. + 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. +Qed. + Theorem eval_add: binary_constructor_sound add Val.add. Proof. red; intros until y. @@ -238,6 +269,11 @@ 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. - TrivialExists. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index adc27010..1f47fd8f 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -371,19 +371,20 @@ Theorem eval_static_operation_sound: 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; - destruct op; try (InvHyps; eauto with va). + unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; 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. - - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + - unfold addx. 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)))). + 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. -- cgit From a17d3c0419ef5531142c4826d962009c9ba81fbc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 17:03:50 +0200 Subject: maddx ordre opposé MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 4 ++++ 2 files changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index ae9d64b9..61365be2 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -144,6 +144,8 @@ Nondetfunction add (e1: expr) (e2: expr) := 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. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7b026bf5..583b6f02 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -274,6 +274,10 @@ Proof. 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. -- cgit From a095ac045485f5693d937864f7990ab5de427f1d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 17:46:45 +0200 Subject: more maddx --- mppa_k1c/SelectOp.vp | 8 ++++++ mppa_k1c/SelectOpproof.v | 66 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 61365be2..9b4cfeb0 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -104,6 +104,12 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) +Definition addimm_shlimm sh k2 e1 := + 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. + Nondetfunction addimm (n: int) (e: expr) := if Int.eq n Int.zero then e else match e with @@ -111,6 +117,8 @@ 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 (Oshlimm sh) (t1:::Enil) => + addimm_shlimm sh n t1 | _ => Eop (Oaddimm n) (e ::: Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 583b6f02..25b34fb9 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -183,6 +183,66 @@ 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 (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. +Qed. + Theorem eval_addimm: forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). Proof. @@ -198,6 +258,12 @@ Proof. + econstructor; split. EvalOp. simpl; eauto. destruct sp; simpl; auto. + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + 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. -- cgit From 17a8d91a82f67d7f62f8cbad41ba76a4b0b82a30 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 20:17:09 +0200 Subject: apply .xs onto addx4 etc --- mppa_k1c/Asmblockgen.v | 6 ++ mppa_k1c/Asmvliw.v | 2 +- mppa_k1c/ExtValues.v | 5 +- mppa_k1c/Op.v | 4 +- mppa_k1c/PostpassSchedulingOracle.ml | 20 +++++-- mppa_k1c/SelectLong.vp | 17 ++++++ mppa_k1c/SelectLongproof.v | 107 +++++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 13 +++-- mppa_k1c/SelectOpproof.v | 29 ++++++---- mppa_k1c/ValueAOp.v | 4 +- 10 files changed, 180 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 7be83962..71af4798 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -449,6 +449,12 @@ Definition transl_op | 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) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e1a7f916..9a933741 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1069,7 +1069,7 @@ Definition arith_eval_rrr n v1 v2 := | Pfmulw => Val.mulfs v1 v2 | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 - | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 32d84b60..284d55f3 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -201,4 +201,7 @@ Proof. Qed. Definition addx sh v1 v2 := - Val.add v2 (Val.shl v1 (Vint sh)). \ No newline at end of file + Val.add v2 (Val.shl v1 (Vint sh)). + +Definition addxl sh v1 v2 := + Val.addl v2 (Val.shll v1 (Vint sh)). \ No newline at end of file diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 69620934..98635677 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -454,8 +454,8 @@ 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 shift, v1 :: v2 :: nil => Some (Val.addl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) - | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | 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) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3618969a..24087caf 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -405,6 +405,10 @@ let alu_lite_x : int array = let resmap = fun r -> match r with | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let alu_lite_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 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 in Array.of_list (List.map resmap resource_names) @@ -588,15 +592,23 @@ let rec_to_usage r = and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw | Addxw -> + | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved | Addxd -> + | Nxord | Andnd | Ornd | Cmoved -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_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) @@ -620,9 +632,9 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) - | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) + | Srsw | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | 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 -> diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index b29b9712..fe739a01 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -66,6 +66,12 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) +Definition addlimm_shllimm sh k2 e1 := + 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. + Nondetfunction addlimm (n: int64) (e: expr) := if Int64.eq n Int64.zero then e else match e with @@ -76,9 +82,16 @@ Nondetfunction addlimm (n: int64) (e: expr) := 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 (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 | _ => Eop (Oaddlimm n) (e ::: Enil) end. +Definition addl_shllimm n e1 e2 := + 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. + Nondetfunction addl (e1: expr) (e2: expr) := if Archi.splitlong then SplitLong.addl e1 e2 else match e1, e2 with @@ -102,6 +115,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. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 257c7fd9..3c9f64d5 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -119,6 +119,67 @@ 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 (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. +Qed. + Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). Proof. unfold addlimm; intros; red; intros. @@ -136,9 +197,47 @@ 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. +- 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 (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. +Qed. + Theorem eval_addl: binary_constructor_sound addl Val.addl. Proof. unfold addl. destruct Archi.splitlong eqn:SL. @@ -193,6 +292,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. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 9b4cfeb0..3427dda3 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -611,13 +611,14 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := 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) => + | Eop (Oaddxl sh) (e1:::e2:::Enil) => + let zscale := ExtValues.z_of_shift1_4 sh in + let scale := Int.repr zscale in (if Compopts.optim_fxsaddr 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)) + 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. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 25b34fb9..8e1812c6 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1377,18 +1377,25 @@ 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 (Z.eq_dec _ _). - * exists (v1 :: v2 :: nil); split. - repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. - * exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. - simpl. congruence. - + exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. + - unfold addxl in *. + destruct (Compopts.optim_fxsaddr 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. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 1f47fd8f..10f25701 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -394,6 +394,7 @@ Proof. end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. + - unfold addxl. eauto with va. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.add n n2) | Vptr b2 ofs2 => @@ -401,8 +402,7 @@ Proof. 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)))). + 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. -- cgit From 66ee59d3dc8a861b468cfaf0ff46fc71dfb8fec2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 21:54:18 +0200 Subject: option -faddx (off by default until questions cleared) --- mppa_k1c/SelectLong.vp | 22 ++++++++++++++-------- mppa_k1c/SelectLongproof.v | 19 +++++++++++++++++-- mppa_k1c/SelectOp.vp | 29 +++++++++++++++++++++-------- mppa_k1c/SelectOpproof.v | 31 +++++++++++++++++++++++++++++-- 4 files changed, 81 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index fe739a01..2450ab97 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -67,10 +67,13 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) Definition addlimm_shllimm sh k2 e1 := - 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. + if Compopts.optim_faddx 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 @@ -87,10 +90,13 @@ Nondetfunction addlimm (n: int64) (e: expr) := end. Definition addl_shllimm n e1 e2 := - 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. + if Compopts.optim_faddx 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 diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3c9f64d5..58a4c39a 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -124,6 +124,8 @@ 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. @@ -178,6 +180,13 @@ Proof. 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)). @@ -188,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. @@ -211,6 +220,8 @@ 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. @@ -235,7 +246,11 @@ Proof. discriminate. (* Oaddxl *) - TrivialExists; - repeat econstructor; eassumption. + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } Qed. Theorem eval_addl: binary_constructor_sound addl Val.addl. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3427dda3..4d2a948d 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -105,10 +105,13 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) Definition addimm_shlimm sh k2 e1 := - 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. + if Compopts.optim_faddx 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 @@ -123,10 +126,13 @@ Nondetfunction addimm (n: int) (e: expr) := end. Definition add_shlimm n e1 e2 := - 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. + if Compopts.optim_faddx 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 @@ -611,6 +617,13 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := 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 + 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 diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 8e1812c6..f5a90803 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -187,6 +187,8 @@ 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. @@ -241,6 +243,13 @@ Proof. 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: @@ -272,6 +281,8 @@ 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. @@ -295,7 +306,11 @@ Proof. apply Int.repr_unsigned. } discriminate. - TrivialExists; - repeat econstructor; eassumption. + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } Qed. Theorem eval_add: binary_constructor_sound add Val.add. @@ -1377,8 +1392,20 @@ 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_xsaddr tt). + + destruct (Z.eq_dec _ _). + * exists (v1 :: v2 :: nil); split. + repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. + * exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. + + exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. - unfold addxl in *. - destruct (Compopts.optim_fxsaddr tt). + destruct (Compopts.optim_xsaddr tt). + unfold int_of_shift1_4 in *. destruct (Z.eq_dec _ _). * exists (v0 :: v1 :: nil); split. -- cgit From 005093b87250b6b27b320eb789574da4bda616c0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 22:40:50 +0200 Subject: correct -faddx option and propagate addim over addxim --- mppa_k1c/SelectLong.vp | 7 ++++--- mppa_k1c/SelectLongproof.v | 5 +++++ mppa_k1c/SelectOp.vp | 14 +++++++------- mppa_k1c/SelectOpproof.v | 5 +++++ 4 files changed, 21 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 2450ab97..4e369e11 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -67,7 +67,7 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) Definition addlimm_shllimm sh k2 e1 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned sh) with | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) @@ -80,17 +80,18 @@ Nondetfunction addlimm (n: int64) (e: expr) := 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_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned n) with | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 58a4c39a..78a2bb31 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -206,6 +206,11 @@ 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. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 4d2a948d..7cf300f8 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -105,7 +105,7 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) Definition addimm_shlimm sh k2 e1 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned sh) with | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) @@ -120,13 +120,13 @@ 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 (Oshlimm sh) (t1:::Enil) => - addimm_shlimm sh n t1 + | 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_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned n) with | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) @@ -612,13 +612,13 @@ 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) @@ -627,7 +627,7 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | Eop (Oaddxl sh) (e1:::e2:::Enil) => let zscale := ExtValues.z_of_shift1_4 sh in let scale := Int.repr zscale in - (if Compopts.optim_fxsaddr tt + (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) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index f5a90803..ad7e4209 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -267,6 +267,11 @@ 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. -- cgit From 6e995893ccae975f49c250387182fcd3e3e6395a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 May 2019 00:42:04 +0200 Subject: directly branch to certain division functions from gcc --- mppa_k1c/TargetPrinter.ml | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 114297c9..3c46ef16 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -34,9 +34,22 @@ module Target (*: TARGET*) = let comment = "#" - let symbol = elf_symbol - let symbol_offset = elf_symbol_offset - let label = elf_label + let subst_symbol = function + "__compcert_i64_udiv" -> "__udivdi3" + | "__compcert_i64_sdiv" -> "__divdi3" + | "__compcert_i64_umod" -> "__umoddi3" + | "__compcert_i64_smod" -> "__moddi3" + | x -> x;; + + let symbol oc symb = + fprintf oc "%s" (subst_symbol (extern_atom symb)) + + let symbol_offset oc (symb, ofs) = + symbol oc symb; + let ofs = camlint64_of_ptrofs ofs in + if ofs <> 0L then fprintf oc " + %Ld" ofs + + let label = elf_label let print_label oc lbl = label oc (transl_label lbl) -- cgit From 644814b1b266f5492e6ffd24776fc87c30acd57b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 May 2019 12:41:49 +0200 Subject: standardize semantics, 1 --- mppa_k1c/Asmvliw.v | 11 +++++------ mppa_k1c/ExtValues.v | 8 +++++++- 2 files changed, 12 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 9a933741..886228ad 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1071,9 +1071,8 @@ Definition arith_eval_rrr n 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 => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) - - | Prevsubxl shift => Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift))) + | 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 := @@ -1100,7 +1099,7 @@ Definition arith_eval_rri32 n v 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 => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i) end. Definition arith_eval_rri64 n v i := @@ -1117,8 +1116,8 @@ 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 => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) - | Prevsubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | 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 arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 284d55f3..9169cf13 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -204,4 +204,10 @@ 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)). \ No newline at end of file + 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)). \ No newline at end of file -- cgit From 26428dbaa2f3fec4b8fd121fc6e53a22a5cc5c5d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 May 2019 13:01:06 +0200 Subject: standardization of expressions --- mppa_k1c/Op.v | 8 ++++---- mppa_k1c/ValueAOp.v | 10 ++++------ 2 files changed, 8 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 98635677..4df157b0 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -408,8 +408,8 @@ Definition eval_operation | 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 (Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) - | Orevsubximm shift n, v1 :: nil => Some (Val.sub (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | 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) @@ -459,8 +459,8 @@ Definition eval_operation | 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 (Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) - | Orevsubxlimm shift n, v1 :: nil => Some (Val.subl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | 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) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 10f25701..f41dae63 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -371,12 +371,11 @@ Theorem eval_static_operation_sound: 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, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs, 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. - - unfold addx. 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 => @@ -389,12 +388,11 @@ Proof. + 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 + | 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 a1; destruct shift; reflexivity. - - unfold addxl. 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 => -- cgit From c1b36f701c8c3968bb5fad86c94dd5ccfa81e3e5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 13 May 2019 13:16:07 +0200 Subject: begin proving that we can use 64-bit division for doing 32 --- mppa_k1c/ExtValues.v | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 5d16b79c..8e00dc99 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -117,3 +117,67 @@ Definition val_shrxl (v1 v2: val): val := else Vundef | _, _ => Vundef end. + +Remark modulus_fits_64: Int.modulus < Int64.max_unsigned. +Proof. + compute. + trivial. +Qed. + +Remark unsigned64_repr : + forall i, + -1 < i < Int.modulus -> + Int64.unsigned (Int64.repr i) = i. +Proof. + intros i H. + destruct H as [Hlow Hhigh]. + apply Int64.unsigned_repr. + split. { omega. } + pose proof modulus_fits_64. + omega. +Qed. + +Theorem divu_is_divlu: forall v1 v2 : val, + Val.divu v1 v2 = + match Val.divlu (Val.longofintu v1) (Val.longofintu v2) with + | None => None + | Some q => Some (Val.loword q) + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + rewrite Int.unsigned_repr by (compute; split; discriminate). + rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). + rewrite (unsigned64_repr i0_val) by assumption. + destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. + f_equal. f_equal. + unfold Int.divu, Int64.divu. simpl. + rewrite (unsigned64_repr i_val) by assumption. + rewrite (unsigned64_repr i0_val) by assumption. + unfold Int64.loword. + rewrite Int64.unsigned_repr. + reflexivity. + destruct (Z.eq_dec i0_val 1). + {subst i0_val. + pose proof modulus_fits_64. + rewrite Zdiv_1_r. + omega. + } + destruct (Z.eq_dec i_val 0). + { subst i_val. compute. + split; + intro ABSURD; + discriminate ABSURD. } + assert ((i_val / i0_val) < i_val). + { apply Z_div_lt; omega. } + split. + { apply Z_div_pos; omega. } + pose proof modulus_fits_64. + omega. +Qed. \ No newline at end of file -- cgit From 5e53b6e6447b22eb34e5be1bc45320ca4e3d82a1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 13 May 2019 14:02:23 +0200 Subject: we directly call 64-bit unsigned division --- mppa_k1c/ExtValues.v | 2 +- mppa_k1c/SelectOp.vp | 6 +++++- mppa_k1c/SelectOpproof.v | 20 ++++++++++++++++++-- 3 files changed, 24 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 8e00dc99..3529a36f 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -180,4 +180,4 @@ Proof. { apply Z_div_pos; omega. } pose proof modulus_fits_64. omega. -Qed. \ No newline at end of file +Qed. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6adcebe5..c4b01d89 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -423,7 +423,11 @@ Definition mods_base (e1: expr) (e2: expr) := Eexternal i32_smod sig_ii_i (e1 ::: e2 ::: Enil). Definition divu_base (e1: expr) (e2: expr) := - Eexternal i32_udiv sig_ii_i (e1 ::: e2 ::: Enil). + Eop Olowlong + ((Eexternal i64_udiv sig_ll_l + ((Eop Ocast32unsigned (e1 ::: Enil))::: + (Eop Ocast32unsigned (e2 ::: Enil))::: Enil)) + :::Enil). Definition modu_base (e1: expr) (e2: expr) := Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 9e2eec8b..2730ee91 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -872,8 +872,24 @@ Theorem eval_divu_base: Val.divu x y = Some z -> exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. - intros; unfold divu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + intros until z. + intros Hax Hby Hdiv. unfold divu_base. + pose proof (divu_is_divlu x y) as DIVU. + destruct (Val.divlu (Val.longofintu x) (Val.longofintu y)) + as [ ql | ] eqn:Ediv. + { TrivialExists. + { econstructor. eapply eval_helper_2; eauto. + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { DeclHelper. } + { UseHelper. } + constructor. } + simpl. + congruence. + } + congruence. Qed. Theorem eval_modu_base: -- cgit From c785f245a68aab9078c37b729fa916f2feae76f0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 13 May 2019 16:44:33 +0200 Subject: 32-bit modulo now uses sign extend then call to the 64-bit function --- mppa_k1c/ExtValues.v | 36 ++++++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 6 +++++- mppa_k1c/SelectOpproof.v | 20 ++++++++++++++++++-- 3 files changed, 59 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3529a36f..991dd3f0 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -181,3 +181,39 @@ Proof. pose proof modulus_fits_64. omega. Qed. + +Theorem modu_is_modlu: forall v1 v2 : val, + Val.modu v1 v2 = + match Val.modlu (Val.longofintu v1) (Val.longofintu v2) with + | None => None + | Some q => Some (Val.loword q) + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + rewrite Int.unsigned_repr by (compute; split; discriminate). + rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). + rewrite (unsigned64_repr i0_val) by assumption. + destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. + f_equal. f_equal. + unfold Int.modu, Int64.modu. simpl. + rewrite (unsigned64_repr i_val) by assumption. + rewrite (unsigned64_repr i0_val) by assumption. + unfold Int64.loword. + rewrite Int64.unsigned_repr. + reflexivity. + assert((i_val mod i0_val) < i0_val). + apply Z_mod_lt. + omega. + split. + { apply Z_mod_lt. + omega. } + pose proof modulus_fits_64. + omega. +Qed. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index c4b01d89..aac3010e 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -430,7 +430,11 @@ Definition divu_base (e1: expr) (e2: expr) := :::Enil). Definition modu_base (e1: expr) (e2: expr) := - Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). + Eop Olowlong + ((Eexternal i64_umod sig_ll_l + ((Eop Ocast32unsigned (e1 ::: Enil))::: + (Eop Ocast32unsigned (e2 ::: Enil))::: Enil)) + :::Enil). Definition shrximm (e1: expr) (n2: int) := if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 2730ee91..d22725d5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -899,8 +899,24 @@ Theorem eval_modu_base: Val.modu x y = Some z -> exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. Proof. - intros; unfold modu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + intros until z. + intros Hax Hby Hmod. unfold modu_base. + pose proof (modu_is_modlu x y) as MODU. + destruct (Val.modlu (Val.longofintu x) (Val.longofintu y)) + as [ ql | ] eqn:Emod. + { TrivialExists. + { econstructor. eapply eval_helper_2; eauto. + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { DeclHelper. } + { UseHelper. } + constructor. } + simpl. + congruence. + } + congruence. Qed. Theorem eval_shrximm: -- cgit From cee86f015217b6899d99b2156bdf6578849481c7 Mon Sep 17 00:00:00 2001 From: tvdd Date: Mon, 13 May 2019 17:51:20 +0200 Subject: star_step_simu_body_step proof --- mppa_k1c/Machblockgenproof.v | 66 +++++++++++++++++++++++++++----------------- 1 file changed, 40 insertions(+), 26 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 91dc58e8..1affe8d2 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -490,31 +490,18 @@ Lemma star_step_simu_body_step s f sp c bdy c': starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. Proof. - induction 1. -Admitted. (* A FINIR *) - -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. - * (* nil *) - inversion_clear H; simpl; intros X; inversion_clear X. - eapply ex_intro; eapply ex_intro; intuition eauto. - * (* cons *) - remember (to_basic_inst i0) as o eqn:Ho. - destruct o as [bi |]. - + (* to_basic_inst i0 = Some bi *) - remember (to_bblock_body c0) as r eqn:Hr. - destruct r as [p1 c1]; inversion H; simpl; subst; clear H. - intros X; inversion_clear X. - exploit step_simu_basic_step; eauto. - intros [rs' [m' [H2 [H3 H4]]]]; subst. - exploit Hc0; eauto. - intros [rs'' [m'' [H5 [H6 H7]]]]; subst. - refine (ex_intro _ rs'' (ex_intro _ m'' _)); intuition eauto. - + (* to_basic_inst i0 = None *) - inversion_clear H; simpl. - intros X; inversion_clear X. intuition eauto. -Qed. -*) + induction 1; simpl. + + intros. inversion H. exists rs. exists m. auto. + + intros. inversion H0. exists rs. exists m. auto. + + intros. inversion H1; subst. + exploit (step_simu_basic_step ); eauto. + destruct 1 as [ rs1 [ m1 Hs]]. + destruct Hs as [Hs1 [Hs2 Hs3]]. + destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. + destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. + exists rs2, m2. + 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. @@ -576,13 +563,40 @@ Proof. Qed. *) + Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: is_exit e c c' -> is_trans_code c' blc -> starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. Proof. - destruct 1. (* A FINIR *) + destruct 1. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + Search trans_code. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + Search trans_code. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* Some *) + intros H0 H1. + inversion H1; subst. + (* A FINIR *) Admitted. +(* +Inductive state : Type := + State : list stackframe -> + block -> val -> code -> regset -> mem -> state + | Callstate : list stackframe -> block -> regset -> mem -> state + | Returnstate : list stackframe -> regset -> mem -> state +*) + (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? Proof. intros H1 H2; destruct e as [ e |]; inversion_clear H2. -- cgit From 13ea0149e1994c5489d9aed00e7486e49d687889 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 14 May 2019 10:03:33 +0200 Subject: some lemmas on division etc. --- mppa_k1c/ExtValues.v | 258 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 258 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 991dd3f0..e9b2610c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -217,3 +217,261 @@ Proof. pose proof modulus_fits_64. omega. Qed. + +Remark if_zlt_0_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt 0 Int.half_modulus) then x else y) = x. +Proof. + reflexivity. +Qed. + +Remark if_zlt_mone_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt (Int.unsigned Int.mone) Int.half_modulus) then x else y) = y. +Proof. + reflexivity. +Qed. + +Remark if_zlt_min_signed_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt (Int.unsigned (Int.repr Int.min_signed)) + Int.half_modulus) + then x + else y) = y. +Proof. + reflexivity. +Qed. + +Lemma repr_unsigned64_repr: + forall x, Int.repr (Int64.unsigned (Int64.repr x)) = Int.repr x. +Proof. + intros. + apply Int.eqm_samerepr. + unfold Int.eqm. + unfold Int.eqmod. + pose proof (Int64.eqm_unsigned_repr x) as H64. + unfold Int64.eqm in H64. + unfold Int64.eqmod in H64. + destruct H64 as [k64 H64]. + change Int64.modulus with 18446744073709551616 in *. + change Int.modulus with 4294967296. + exists (-4294967296 * k64). + set (y := Int64.unsigned (Int64.repr x)) in *. + rewrite H64. + clear H64. + omega. +Qed. + +(* +Theorem divs_is_divls: forall v1 v2 : val, + match Val.divs v1 v2 with + | Some q => + match Val.divls (Val.longofint v1) (Val.longofint v2) with + | None => False + | Some q' => q = Val.loword q' + end + | None => True + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + replace (Int.unsigned (Int.repr 0)) with 0 in * by reflexivity. + destruct (zeq _ _) as [H0' | Hnot0]; simpl; trivial. + destruct (zeq i_val (Int.unsigned (Int.repr Int.min_signed))) as [Hmin | Hnotmin]; simpl. + { subst. + destruct (zeq i0_val (Int.unsigned Int.mone)) as [Hmone | Hnotmone]; trivial. + unfold Int.signed. simpl. + replace (Int64.unsigned (Int64.repr 0)) with 0 in * by reflexivity. + rewrite if_zlt_min_signed_half_modulus. + replace (if + zeq + (Int64.unsigned + (Int64.repr + (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) + (Int64.unsigned (Int64.repr Int64.min_signed)) + then true + else false) with false by reflexivity. + simpl. + rewrite orb_false_r. + destruct (zlt i0_val Int.half_modulus) as [Hlt_half | Hge_half]. + { + replace Int.half_modulus with 2147483648 in * by reflexivity. + rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; omega). + destruct (zeq _ _) as [ | Hneq0]; try omega. clear Hneq0. + unfold Val.loword. + f_equal. + unfold Int64.divs, Int.divs, Int64.loword. + unfold Int.signed, Int64.signed. simpl. + rewrite if_zlt_min_signed_half_modulus. + change Int.half_modulus with 2147483648 in *. + destruct (zlt _ _) as [discard|]; try omega. clear discard. + change (Int64.unsigned + (Int64.repr + (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) + with 18446744071562067968. + change Int64.half_modulus with 9223372036854775808. + change Int64.modulus with 18446744073709551616. + simpl. + rewrite (Int64.unsigned_repr i0_val) by (change Int64.max_unsigned with 18446744073709551615; omega). + destruct (zlt i0_val 9223372036854775808) as [discard |]; try omega. + clear discard. + change (Int.unsigned (Int.repr Int.min_signed) - Int.modulus) with (-2147483648). + destruct (Z.eq_dec i0_val 1) as [H1 | Hnot1]. + { subst. + rewrite Z.quot_1_r. + apply Int.eqm_samerepr. + unfold Int.eqm. + change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968. + unfold Int.eqmod. + change Int.modulus with 4294967296. + exists (-4294967296). + compute. + reflexivity. + } + change (-2147483648) with (-(2147483648)). + rewrite Z.quot_opp_l by assumption. + rewrite repr_unsigned64_repr. + reflexivity. + } + destruct (zeq _ _) as [Hmod|Hnmod]. + { + rewrite Int64.unsigned_repr_eq in Hmod. + set (delta := (i0_val - Int.modulus)) in *. + assert (delta = Int64.modulus*(delta/Int64.modulus)) as Hdelta. + { apply Z_div_exact_full_2. + compute. omega. + assumption. } + set (k := (delta / Int64.modulus)) in *. + change Int64.modulus with 18446744073709551616 in *. + change Int.modulus with 4294967296 in *. + change Int.half_modulus with 2147483648 in *. + change (Int.unsigned Int.mone) with 4294967295 in *. + omega. + } + unfold Int.divs, Int64.divs, Val.loword, Int64.loword. + change (Int.unsigned (Int.repr Int.min_signed)) with 2147483648. + change Int.modulus with 4294967296. + change (Int64.signed (Int64.repr (2147483648 - 4294967296))) with (-2147483648). + f_equal. + change (Int.signed {| Int.intval := 2147483648; Int.intrange := i_range |}) + with (-2147483648). + rewrite Int64.signed_repr. + { + replace (Int.signed {| Int.intval := i0_val; Int.intrange := i0_range |}) with (i0_val - 4294967296). + { rewrite repr_unsigned64_repr. + reflexivity. + } + *) + +Lemma big_unsigned_signed: + forall x, + (Int.unsigned x >= Int.half_modulus) -> + (Int.signed x) = (Int.unsigned x) - Int.modulus. +Proof. + destruct x as [xval xrange]. + intro BIG. + unfold Int.signed, Int.unsigned in *. simpl in *. + destruct (zlt _ _). + omega. + trivial. +Qed. + +(* +Lemma signed_0_eqb : + forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero. +Admitted. + *) + +Lemma Z_quot_le: forall a b, + 0 <= a -> 1 <= b -> Z.quot a b <= a. +Proof. + intros a b Ha Hb. + destruct (Z.eq_dec b 1) as [Hb1 | Hb1]. + { (* b=1 *) + subst. + rewrite Z.quot_1_r. + auto with zarith. + } + destruct (Z.eq_dec a 0) as [Ha0 | Ha0]. + { (* a=0 *) + subst. + rewrite Z.quot_0_l. + auto with zarith. + omega. + } + assert ((Z.quot a b) < a). + { + apply Z.quot_lt; omega. + } + auto with zarith. +Qed. + +(* +Lemma divs_is_quot: forall v1 v2 : val, + Val.divs v1 v2 = + match v1, v2 with + | (Vint w1), (Vint w2) => + let q := Z.quot (Int.signed w1) (Int.signed w2) in + if (negb (Z.eqb (Int.signed w2) 0)) + && (Z.geb q Int.min_signed) && (Z.leb q Int.max_signed) + then Some (Vint (Int.repr q)) + else None + | _, _ => None + end. + +Proof. + destruct v1; destruct v2; simpl; trivial. + unfold Int.divs. + rewrite signed_0_eqb. + destruct (Int.eq i0 Int.zero) eqn:Eeq0; simpl; trivial. + destruct (Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:EXCEPTION. + { replace (Int.signed i0) with (-1). + replace (Int.signed i) with Int.min_signed. + change Int.min_signed with (-2147483648). + change Int.max_signed with (2147483647). + compute. + reflexivity. + { unfold Int.eq in EXCEPTION. + destruct (zeq _ _) as [Hmin | ] in EXCEPTION; try discriminate. + change Int.min_signed with (-2147483648). + change (Int.unsigned (Int.repr Int.min_signed)) with (2147483648) in *. + rewrite big_unsigned_signed. + change Int.modulus with 4294967296. + omega. + change Int.half_modulus with 2147483648. + omega. + } + unfold Int.eq in EXCEPTION. + destruct (zeq _ _) in EXCEPTION; try discriminate. + destruct (zeq _ _) as [Hmone | ] in EXCEPTION; try discriminate. + destruct i0 as [i0val i0range]; unfold Int.signed in *; simpl in *. + rewrite Hmone. + reflexivity. + } + replace (Int.signed i ÷ Int.signed i0 >=? Int.min_signed) with true. + replace (Int.signed i ÷ Int.signed i0 <=? Int.max_signed) with true. + reflexivity. + { assert (Int.signed i ÷ Int.signed i0 <= Int.max_signed). + { + destruct (Z_lt_le_dec (Int.signed i) 0). + { + apply Z.le_trans with (m:=0). + rewrite <- (Z.quot_0_l (Int.signed i0)). + Require Import Coq.ZArith.Zquot. + apply Z_quot_monotone. + } + assert ( Int.signed i ÷ Int.signed i0 <= Int.signed i). + apply Z_quot_le. + } + } + +*) \ No newline at end of file -- cgit From b15c0109a6e6a6bbba1c09a0c5fbfdc6ecf51f0e Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 14 May 2019 13:02:40 +0200 Subject: abstractbb: support of removing useless computations --- mppa_k1c/abstractbb/DepTreeTheory.v | 365 +++++++++++---------- mppa_k1c/abstractbb/ImpDep.v | 264 ++++++++------- mppa_k1c/abstractbb/Impure/ImpCore.v | 10 +- mppa_k1c/abstractbb/Impure/ImpHCons.v | 95 +++++- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 29 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 16 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 1 + 7 files changed, 481 insertions(+), 299 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index bf45d11a..6646d4f5 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -1,13 +1,13 @@ (** Dependency Trees of Abstract Basic Blocks -with a purely-functional-but-exponential equivalence test. +with a purely-functional-but-exponential test. *) Require Setoid. (* in order to rewrite <-> *) Require Export AbstractBasicBlocksDef. - +Require Import List. Module Type PseudoRegDictionary. @@ -39,12 +39,9 @@ Module DepTree (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R Export L. Export LP. -Local Open Scope list. Section DEPTREE. -Variable ge: genv. - (** Dependency Trees of these "bblocks" NB: each tree represents the successive computations in one given resource @@ -54,102 +51,90 @@ NB: each tree represents the successive computations in one given resource Inductive tree := | Tname (x:R.t) | Top (o: op) (l: list_tree) - | Terase (new old:tree) (* assignment in the resource: [new] replaces [old] *) with list_tree := | Tnil: list_tree | Tcons (t:tree) (l:list_tree): list_tree . -Fixpoint tree_eval (t: tree) (m: mem): option value := +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 l m with + match list_tree_eval ge l m with | Some v => op_eval ge o v | _ => None end - | Terase new old => - (* NB: we simply check whether the old computations has aborted *) - match tree_eval old m with - | Some _ => tree_eval new m - | _ => None - end end -with list_tree_eval (l: list_tree) (m: mem) {struct l}: option (list value) := +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 t m), (list_tree_eval l' m) with + 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:= Dict.t tree. - -Definition deps_get (d:deps) x := +Definition deps_get (d:Dict.t tree) x := match Dict.get d x with | None => Tname x | Some t => t end. -Lemma set_spec_eq d x t: - deps_get (Dict.set d x t) x = t. -Proof. - unfold deps_get; rewrite Dict.set_spec_eq; simpl; auto. -Qed. - -Lemma set_spec_diff d x y t: - x <> y -> deps_get (Dict.set d x t) y = deps_get d y. -Proof. - unfold deps_get; intros; rewrite Dict.set_spec_diff; simpl; auto. -Qed. - -Lemma empty_spec x: deps_get Dict.empty x = Tname x. -Proof. - unfold deps_get; rewrite Dict.empty_spec; simpl; auto. -Qed. - -Hint Rewrite set_spec_eq empty_spec: dict_rw. - -Fixpoint exp_tree (e: exp) (d old: deps): tree := +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: deps): list_tree := +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. -Definition failsafe (t: tree): bool := - match t with - | Tname x => true - | Top o Tnil => is_constant o - | _ => false - 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. -Local Hint Resolve is_constant_correct. +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 failsafe_correct (t: tree) m: failsafe t = true -> tree_eval t m <> None. +Lemma deps_eval_empty x m: deps_eval ge deps_empty x m = Some (m x). Proof. - destruct t; simpl; try congruence. - destruct l; simpl; try congruence. - eauto. + 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 t0:=deps_get d x in - let t1:=exp_tree e d old in - let v':=if failsafe t0 then t1 else (Terase t1 t0) in - inst_deps i' (Dict.set d x v') old + 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 := @@ -160,214 +145,236 @@ Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps := bblock_deps_rec p' d' end. +Local Hint Resolve deps_eval_empty. + Definition bblock_deps: bblock -> deps - := fun p => bblock_deps_rec p Dict.empty. + := 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. -(** Main Result: the [bblock_deps_equiv] theorem states that bblocks with the same dependencies are observationaly equals *) +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, tree_eval (deps_get od x) m0 = Some (old x)) -> - forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (tree_eval (exp_tree e d od) m0) = exp_eval ge e m1 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. - intro H. - induction e using exp_mut with (P0:=fun l => forall d m1, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval (list_exp_tree l d od) m0 = list_exp_eval ge l m1 old); simpl; auto. + 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. + - intros. erewrite IHe, IHe0; eauto. Qed. -Lemma tree_eval_inst_abort i m0 x old: forall d, - tree_eval (deps_get d x) m0 = None -> - tree_eval (deps_get (inst_deps i d old) x) m0 = None. +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 H; erewrite IHi; eauto. clear IHi. + intros d VALID H; erewrite IHi; eauto. clear IHi. destruct (R.eq_dec x y). * subst; autorewrite with dict_rw. - generalize (failsafe_correct (deps_get d y) m0). - destruct (failsafe (deps_get d y)); simpl; intuition try congruence. - rewrite H; simpl. auto. - * rewrite! set_spec_diff; auto. + generalize (inst_deps_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold deps_set; simpl; intuition congruence. + * rewrite set_spec_diff; auto. Qed. -Lemma tree_eval_abort p m0 x: forall d, - tree_eval (deps_get d x) m0 = None -> - tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. +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 H; erewrite IHp; eauto. clear IHp. - eapply tree_eval_inst_abort; eauto. + intros d VALID H; erewrite IHp; eauto. clear IHp. + eapply inst_deps_abort; eauto. Qed. -Lemma tree_eval_inst_Some_correct1 i m0 old od: - (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> - forall (m1 m2: mem) d, +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, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (inst_deps i d od) x) m0 = Some (m2 x)). + (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. - remember (exp_eval ge e m1 old) as ov. - destruct ov. - + refine (IHi _ _ _ _ _ _); eauto. - clear x0; intros x0. - unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. - + inversion H. + 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. -Local Hint Resolve tree_eval_inst_Some_correct1 tree_eval_abort. - -Lemma tree_eval_Some_correct1 p m0: forall (m1 m2: mem) d, +Lemma bblocks_deps_rec_Some_correct1 p m0: forall (m1 m2: mem) d, run ge p m1 = Some m2 -> - (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)). + (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. - remember (inst_run ge i m1 m1) as om. - destruct om. + 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, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x). + run ge p m0 = Some m1 + -> forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x). Proof. - intros; eapply tree_eval_Some_correct1; - intros; autorewrite with dict_rw; simpl; eauto. + intros; eapply bblocks_deps_rec_Some_correct1; eauto. Qed. -Lemma tree_eval_inst_None_correct i m0 old od: - (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> - forall m1 d, (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - inst_run ge i m1 old = None <-> exists x, tree_eval (deps_get (inst_deps i d od) x) m0 = None. +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. - - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. - - intros H0. - remember (exp_eval ge e m1 old) as ov. - destruct ov. - + refine (IHi _ _ _); eauto. + - 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. - destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; erewrite tree_eval_exp; eauto. * rewrite set_spec_diff; auto. + intuition. constructor 1 with (x:=x); simpl. - apply tree_eval_inst_abort. + apply inst_deps_abort; auto. autorewrite with dict_rw. - destruct (failsafe (deps_get d x)); simpl; try rewrite H0; erewrite tree_eval_exp; eauto. Qed. - -Lemma tree_eval_None_correct p m0: forall m1 d, - (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - run ge p m1 = None <-> exists x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = None. -Proof. - induction p as [|i p IHp]; simpl; intros m1 d. - - constructor 1; [discriminate | intros [x H']; rewrite H in H'; discriminate]. - - intros H0. - remember (inst_run ge i m1 m1) as om. - destruct om. - + refine (IHp _ _ _); eauto. - + intuition. - assert (X: inst_run ge i m1 m1 = None); auto. - rewrite tree_eval_inst_None_correct in X; auto. - destruct X as [x H1]. - constructor 1 with (x:=x); simpl; auto. -Qed. - -Lemma bblock_deps_None_correct p m: - run ge p m = None <-> exists x, tree_eval (deps_get (bblock_deps p) x) m = None. -Proof. - intros; eapply tree_eval_None_correct. - intros; autorewrite with dict_rw; simpl; eauto. -Qed. - -Lemma tree_eval_inst_Some_correct2 i m0 old od: - (forall x, tree_eval (deps_get od x) m0 = Some (old x)) -> +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, - (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (inst_deps i d od) x) m0 = Some (m2 x)) -> - res_eq (Some m2) (inst_run ge i m1 old). + 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 H0. + 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. - remember (exp_eval ge e m1 old) as ov. - destruct ov. - + refine (IHi _ _ _ _ _); eauto. + 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. - destruct (failsafe (deps_get d x0)); simpl; try rewrite H0; + * subst. autorewrite with dict_rw. erewrite tree_eval_exp; eauto. * rewrite set_spec_diff; auto. + generalize (H x). - rewrite tree_eval_inst_abort; try discriminate. + rewrite inst_deps_abort; discriminate || auto. autorewrite with dict_rw. - destruct (failsafe (deps_get d x)); simpl; try rewrite H0; erewrite tree_eval_exp; eauto. Qed. -Lemma tree_eval_Some_correct2 p m0: forall (m1 m2: mem) d, - (forall x, tree_eval (deps_get d x) m0 = Some (m1 x)) -> - (forall x, tree_eval (deps_get (bblock_deps_rec p d) x) m0 = Some (m2 x)) -> +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 H0. + 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. - remember (inst_run ge i m1 m1) as om. - destruct om. - + refine (IHp _ _ _ _ _); eauto. - + assert (X: inst_run ge i m1 m1 = None); auto. - rewrite tree_eval_inst_None_correct in X; auto. + 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). - rewrite tree_eval_abort; congruence. + erewrite block_deps_rec_abort; eauto. + congruence. Qed. + Lemma bblock_deps_Some_correct2 p m0 m1: - (forall x, tree_eval (deps_get (bblock_deps p) x) m0 = Some (m1 x)) + 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 tree_eval_Some_correct2; eauto. - intros; autorewrite with dict_rw; simpl; eauto. + 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. Theorem bblock_deps_simu p1 p2: - (forall x, deps_get (bblock_deps p1) x = deps_get (bblock_deps p2) x) - -> bblock_simu ge p1 p2. + (forall m, pre (bblock_deps p1) ge m -> pre (bblock_deps p2) ge m) -> + (forall m0 x m1, pre (bblock_deps p1) ge 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. - intros H m2 DONTFAIL. - remember (run ge p1 m2) as om1. - destruct om1; simpl. - + apply bblock_deps_Some_correct2. - intros; rewrite <- H. - apply bblock_deps_Some_correct1; auto. - + rewrite bblock_deps_None_correct. - assert (X: run ge p1 m2 = None); auto. - rewrite bblock_deps_None_correct in X. - destruct X as [x Hx]. - rewrite H in Hx. - eauto. + Local Hint Resolve bblock_deps_valid bblock_deps_Some_correct1. + intros INCL EQUIV m DONTFAIL. + destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. + eapply bblock_deps_Some_correct2; eauto. Qed. End DEPTREE. diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 2e2ad40f..3efe6a36 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -72,8 +72,6 @@ Hypothesis hC_tree_correct: forall t, WHEN hC_tree t ~> t' THEN pre_data t=data 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'. -Variable ge: genv. - (* First, we wrap constructors for hashed values !*) Local Open Scope positive. @@ -107,19 +105,6 @@ Qed. Global Opaque hTop. Hint Resolve hTop_correct: wlp. -Definition hTerase (t1 t2: hashV tree) (debug: option pstring): ?? hashV tree := - DO hc <~ hash 3;; - hC_tree {| pre_data:=Terase (data t1) (data t2); - hcodes:=[hc;hid t1; hid t2]; debug_info := debug |}. - -Lemma hTerase_correct t1 t2 dbg: - WHEN hTerase t1 t2 dbg ~> t THEN (data t)=(Terase (data t1) (data t2)). -Proof. - wlp_simplify. -Qed. -Global Opaque hTerase. -Hint Resolve hTerase_correct: wlp. - Definition hTnil (_: unit): ?? hashV list_tree := hC_list_tree {| pre_data:=Tnil; hcodes := nil; debug_info := None |} . @@ -146,7 +131,9 @@ Hint Resolve hTcons_correct: wlp. (* Second, we use these hashed constructors ! *) -Definition hdeps:= Dict.t (hashV tree). +Record hdeps:= {hpre: list (hashV tree); hpost: Dict.t (hashV tree)}. + +Coercion hpost: hdeps >-> Dict.t. (* pseudo deps_get *) Definition pdeps_get (d:hdeps) x : tree := @@ -169,6 +156,12 @@ 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 <-> pre d ge m) + /\ (forall m x, tree_eval ge (pdeps_get hd x) m = deps_eval ge d x m). + Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree := match e with | PReg x => hdeps_get d x dbg @@ -187,86 +180,95 @@ with hlist_exp_tree (le: list_exp) (d od: hdeps): ?? hashV list_tree := | LOld le => hlist_exp_tree le od od end. -Lemma hexp_tree_correct_x e od1 od2: - (forall x, pdeps_get od1 x = deps_get od2 x) -> - forall d1 d2 dbg, - (forall x, pdeps_get d1 x = deps_get d2 x) -> - WHEN hexp_tree e d1 od1 dbg ~> t THEN data t = exp_tree e d2 od2. +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, 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 d1 d2, - (forall x, pdeps_get d1 x = deps_get d2 x) -> - WHEN hlist_exp_tree le d1 od1 ~> lt THEN data lt = list_exp_tree le d2 od2); simpl; wlp_simplify; congruence. + 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, 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; try congruence. + - rewrite H4, <- H0; simpl; reflexivity. + - rewrite H1; simpl; reflexivity. + - rewrite H5, <- H0, <- H4; simpl; reflexivity. Qed. Global Opaque hexp_tree. -Lemma hexp_tree_correct e d1 od1 dbg: - WHEN hexp_tree e d1 od1 dbg ~> t THEN forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> (forall x, pdeps_get d1 x = deps_get d2 x) -> data t = exp_tree e d2 od2. +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 -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. Proof. - intros t H od2 d2 H1 H2; apply (hexp_tree_correct_x e od1 od2 H1 d1 d2 dbg H2 t H). + unfold wlp; intros; eapply hexp_tree_correct_x; eauto. Qed. Hint Resolve hexp_tree_correct: wlp. -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 t0 <~ hdeps_get d x None;; - DO v' <~ (if failsafe (data t0) - then - hexp_tree e d od dbg - else - DO t1 <~ hexp_tree e d od None;; - hTerase t1 t0 dbg);; - hinst_deps i' (Dict.set d x v') od +Definition failsafe (t: tree): bool := + match t with + | Tname x => true + | Top o Tnil => is_constant o + | _ => false end. -Lemma pset_spec_eq d x t: - pdeps_get (Dict.set d x t) x = (data t). -Proof. - unfold pdeps_get; rewrite Dict.set_spec_eq; simpl; auto. -Qed. +Local Hint Resolve is_constant_correct. -Lemma pset_spec_diff d x y t: - x <> y -> pdeps_get (Dict.set d x t) y = pdeps_get d y. +Lemma failsafe_correct ge (t: tree) m: failsafe t = true -> tree_eval ge t m <> None. Proof. - unfold pdeps_get; intros; rewrite Dict.set_spec_diff; simpl; auto. + destruct t; simpl; try congruence. + destruct l; simpl; try congruence. + eauto. Qed. - -Lemma pempty_spec x: pdeps_get Dict.empty x = Tname x. +Local Hint Resolve failsafe_correct. + +Definition hdeps_set (d:hdeps) x (t:hashV tree) := + DO ot <~ hdeps_get d x None;; + RET {| hpre:=if failsafe (data ot) then d.(hpre) else ot::d.(hpre); + hpost:=Dict.set d 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, tree_eval ge (data ht) m = tree_eval ge t m) -> (* TODO: condition à revoir, on peut sans doute relâcher ici ! *) + deps_model ge (deps_set d x t) nhd. Proof. - unfold pdeps_get; rewrite Dict.empty_spec; simpl; auto. + intros; wlp_simplify. + unfold deps_model, deps_set; simpl. destruct H0 as (DM0 & DM1); split. + - intros m; unfold hdeps_valid in DM0 |- *; simpl. + generalize (failsafe_correct ge (data exta) m); intros FAILSAFE. + destruct (DM0 m) as (H2 & H3); clear DM0. unfold deps_eval in * |- *. + destruct (failsafe _); simpl. + * rewrite !H, !DM1 in * |- *; intuition (subst; eauto). + * clear FAILSAFE. rewrite <- DM1, <- H. intuition (subst; eauto). + - clear H DM0. unfold deps_eval, pdeps_get, deps_get in * |- *; simpl. + intros; case (R.eq_dec x x0). + + intros; subst; rewrite !Dict.set_spec_eq; simpl; auto. + + intros; rewrite !Dict.set_spec_diff; simpl; auto. Qed. +Local Hint Resolve hdeps_set_correct: wlp. +Global Opaque hdeps_set. -Hint Rewrite pset_spec_eq pempty_spec: dict_rw. +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 d1 od1, - WHEN hinst_deps i d1 od1 ~> d1' THEN - forall od2 d2, (forall x, pdeps_get od1 x = deps_get od2 x) -> - (forall x, pdeps_get d1 x = deps_get d2 x) -> - forall x, pdeps_get d1' x = deps_get (inst_deps i d2 od2) x. +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 -> deps_model ge (inst_deps i d od) hd'. Proof. induction i; simpl; wlp_simplify. - + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). - - erewrite H0, H2; simpl; eauto. clear exta2 Hexta2 H2; auto. - intros x0; destruct (R.eq_dec a0 x0). - * subst. autorewrite with dict_rw. rewrite set_spec_eq. erewrite H1; eauto. - * rewrite set_spec_diff, pset_spec_diff; auto. - - rewrite H, H4; auto. - + cutrewrite (failsafe (deps_get d2 a0) = failsafe (data exta0)). - - erewrite H0, H3; simpl; eauto. clear exta3 Hexta3 H3; auto. - intros x0; destruct (R.eq_dec a0 x0). - * subst; autorewrite with dict_rw. rewrite H2. - erewrite H, H1; eauto. rewrite set_spec_eq. congruence. - * rewrite set_spec_diff, pset_spec_diff; auto. - - rewrite H, H5; auto. Qed. Global Opaque hinst_deps. -Hint Resolve hinst_deps_correct: wlp. +Local Hint Resolve hinst_deps_correct: wlp. (* logging info: we log the number of inst-instructions passed ! *) Variable log: unit -> ?? unit. @@ -280,24 +282,24 @@ Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := hbblock_deps_rec p' d' end. -Lemma hbblock_deps_rec_correct p: forall d1, - WHEN hbblock_deps_rec p d1 ~> d1' THEN - forall d2, (forall x, pdeps_get d1 x = deps_get d2 x) -> forall x, pdeps_get d1' x = deps_get (bblock_deps_rec p d2) x. +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. -Hint Resolve hbblock_deps_rec_correct: wlp. +Local Hint Resolve hbblock_deps_rec_correct: wlp. Definition hbblock_deps: bblock -> ?? hdeps - := fun p => hbblock_deps_rec p Dict.empty. + := fun p => hbblock_deps_rec p {| hpre:= nil ; hpost := Dict.empty |}. Lemma hbblock_deps_correct p: - WHEN hbblock_deps p ~> d1 THEN forall x, pdeps_get d1 x = deps_get (bblock_deps p) x. + WHEN hbblock_deps p ~> hd THEN forall ge, deps_model ge (bblock_deps p) hd. Proof. - unfold bblock_deps; wlp_simplify. erewrite H; eauto. - intros; autorewrite with dict_rw; auto. rewrite empty_spec. reflexivity. + unfold bblock_deps; wlp_simplify. eapply H. clear H. + unfold deps_model, pdeps_get, hdeps_valid, deps_eval, deps_get; simpl. + intuition; rewrite !Dict.empty_spec; simpl; auto. Qed. Global Opaque hbblock_deps. @@ -324,11 +326,6 @@ Definition tree_hash_eq (ta tb: tree): ?? bool := DO b <~ op_eq oa ob ;; if b then phys_eq lta ltb else RET false - | Terase t1a t2a, Terase t1b t2b => - DO b <~ phys_eq t1a t1b ;; - if b - then phys_eq t2a t2b - else RET false | _,_ => RET false end. @@ -358,7 +355,7 @@ Qed. Global Opaque list_tree_hash_eq. Hint Resolve list_tree_hash_eq_correct: wlp. -Lemma pdeps_get_intro d1 d2: +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. @@ -366,6 +363,19 @@ 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 !!! ***) @@ -376,7 +386,6 @@ 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. @@ -385,34 +394,48 @@ 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 RET true - else ( + 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, _ => - print_error s;; - RET false + 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 [X1 X2], hco_list_correct as [Y1 Y2]. + 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; rewrite <- H, <- H0. - apply pdeps_get_intro. auto. + + intros m; rewrite <- EQPRE1, <- EQPRE2. + unfold incl, hdeps_valid in * |- *; intuition eauto. + + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2. + erewrite pdeps_get_intro; auto. auto. 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 exta; simpl in * |- *; auto. + destruct exta0; simpl in * |- *; auto. Qed. Global Opaque g_bblock_simu_test. @@ -429,6 +452,7 @@ 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). @@ -437,17 +461,30 @@ 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) p1 p2. -Obligation 1. + 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. +Obligation 2. generalize (hCons_correct _ _ _ _ H); clear H. constructor 1; wlp_simplify. Qed. @@ -486,10 +523,6 @@ Definition print_raw_htree (td: pre_hashV tree): ?? unit := DO so <~ string_of_op o;; DO sl <~ string_of_hashcode lid;; println (so +; " " +; (list_id sl)) - | (Terase _ _), [ _ ; t1; t2 ] => - DO st1 <~ string_of_hashcode t1 ;; - DO st2 <~ string_of_hashcode t2 ;; - println((tree_id st1) +; " erases " +; (tree_id st2)) | _, _ => FAILWITH "unexpected hcodes" end. @@ -521,9 +554,6 @@ Fixpoint string_of_tree (t: tree) (pt: pre_hashV tree) : ?? pstring := DO pl <~ get_hlist lid;; DO sl <~ string_of_list_tree l pl;; RET (so +; "(" +; sl +; ")") - | Terase t _, [ _ ; tid; _ ] => - DO pt <~ get_htree tid ;; - string_of_tree t pt | _, _ => FAILWITH "unexpected hcodes" end end @@ -699,11 +729,13 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := (log_debug log1) simple_debug (hlog log1 hco_tree hco_list) - (log_insert log2) - 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) + (print_error1 hco_tree hco_list cr log2) + true + failpreserv_error (* TODO: debug info *) p1 p2;; if result1 then RET true @@ -718,10 +750,12 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := simple_debug (hlog log1 hco_tree hco_list) (log_insert log2) - hco_tree _ - hco_list _ + hco_tree _ + hco_list _ (print_error_end2 hco_tree hco_list) - (print_error2 hco_tree hco_list cr log2) + (print_error2 hco_tree hco_list cr log2) + false + (fun _ => RET tt) p2 p1;; if result2 then ( @@ -796,7 +830,7 @@ Proof. Qed. Global Opaque eq_test. -(* get some key of a non-empty d *) +(* 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" @@ -809,7 +843,7 @@ Fixpoint pick {A} (d: t A): ?? R.t := 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 diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index 55e67608..7925f62d 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -132,6 +132,13 @@ Proof. destruct x; simpl; auto. Qed. +Lemma wlp_option (A B: Type) (x: option A) (k1: A -> ??B) (k2: ??B) (P: B -> Prop): + (forall a, x=Some a -> wlp (k1 a) P) -> + (x=None -> wlp k2 P) -> + (wlp (match x with Some a => k1 a | None => k2 end) P). +Proof. + destruct x; simpl; auto. +Qed. (* Tactics @@ -156,6 +163,7 @@ Ltac wlp_decompose := || apply wlp_letprod || apply wlp_sum || apply wlp_sumbool + || apply wlp_option . (* this tactic simplifies the current "wlp" goal using any hint found via tactic "hint". *) @@ -185,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 307eb163..dd615628 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -3,8 +3,6 @@ Require Export ImpIO. Import Notations. Local Open Scope impure. -(********************************) -(* (Weak) HConsing *) Axiom string_of_hashcode: hashcode -> ?? caml_string. Extract Constant string_of_hashcode => "string_of_int". @@ -12,6 +10,99 @@ Extract Constant string_of_hashcode => "string_of_int". Axiom hash: forall {A}, A -> ?? hashcode. Extract Constant hash => "Hashtbl.hash". +(**************************) +(* (Weak) Sets *) + + +Import Dict. + +Axiom make_dict: forall {A B}, (hash_params A) -> ?? Dict.t A B. +Extract Constant make_dict => "ImpHConsOracles.make_dict". + + +Module Sets. + +Definition t {A} (mod: A -> Prop) := Dict.t A {x | mod x}. + +Definition empty {A} (hp: hash_params A) {mod:A -> Prop}: ?? t mod := + make_dict hp. + +Program Fixpoint add {A} (l: list A) {mod: A -> Prop} (d: t mod): forall {H:forall x, List.In x l -> mod x}, ?? unit := + match l with + | nil => fun H => RET () + | x::l' => fun H => + d.(set)(x,x);; + add l' d + end. + +Program Definition create {A} (hp: hash_params A) (l:list A): ?? t (fun x => List.In x l) := + DO d <~ empty hp (mod:=fun x => List.In x l);; + add l (mod:=fun x => List.In x l) d (H:=_);; + RET d. +Global Opaque create. + +Definition is_present {A} (hp: hash_params A) (x:A) {mod} (d:t mod): ?? bool := + DO oy <~ (d.(get)) x;; + match oy with + | Some y => hp.(test_eq) x (`y) + | None => RET false + end. + +Local Hint Resolve test_eq_correct: wlp. + +Lemma is_present_correct A (hp: hash_params A) x mod (d:t mod): + WHEN is_present hp x d ~> b THEN b=true -> mod x. +Proof. + wlp_simplify; subst; eauto. + - apply proj2_sig. + - discriminate. +Qed. +Hint Resolve is_present_correct: wlp. +Global Opaque is_present. + +Definition msg_assert_incl: pstring := "Sets.assert_incl". + +Fixpoint assert_incl {A} (hp: hash_params A) (l: list A) {mod} (d:t mod): ?? unit := + match l with + | nil => RET () + | x::l' => + DO b <~ is_present hp x d;; + if b then + assert_incl hp l' d + else ( + hp.(log) x;; + FAILWITH msg_assert_incl + ) + end. + +Lemma assert_incl_correct A (hp: hash_params A) l mod (d:t mod): + WHEN assert_incl hp l d ~> _ THEN forall x, List.In x l -> mod x. +Proof. + induction l; wlp_simplify; subst; eauto. +Qed. +Hint Resolve assert_incl_correct: wlp. +Global Opaque assert_incl. + +Definition assert_list_incl {A} (hp: hash_params A) (l1 l2: list A): ?? unit := + (* println "";;print("dict_create ");;*) + DO d <~ create hp l2;; + (*print("assert_incl ");;*) + assert_incl hp l1 d. + +Lemma assert_list_incl_correct A (hp: hash_params A) l1 l2: + WHEN assert_list_incl hp l1 l2 ~> _ THEN List.incl l1 l2. +Proof. + wlp_simplify. +Qed. +Global Opaque assert_list_incl. +Hint Resolve assert_list_incl_correct. + +End Sets. + +(********************************) +(* (Weak) HConsing *) + + Axiom xhCons: forall {A}, ((A -> A -> ?? bool) * (pre_hashV A -> ?? hashV A)) -> ?? hashConsing A. Extract Constant xhCons => "ImpHConsOracles.xhCons". diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 0efa042c..1a84eb3b 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -91,11 +91,37 @@ Extract Inlined Constant struct_eq => "(=)". Hint Resolve struct_eq_correct: wlp. -(** Data-structure for generic hash-consing *) +(** Data-structure for generic hash-consing, hash-set *) Axiom hashcode: Type. Extract Constant hashcode => "int". +Module Dict. + +Record hash_params {A:Type} := { + test_eq: A -> A -> ??bool; + test_eq_correct: forall x y, WHEN test_eq x y ~> r THEN r=true -> x=y; + hashing: A -> ??hashcode; + log: A -> ??unit (* for debugging only *) +}. +Arguments hash_params: clear implicits. + + +Record t {A B:Type} := { + set: A * B -> ?? unit; + get: A -> ?? option B +}. +Arguments t: clear implicits. + +End Dict. + + +(* 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; hcodes: list hashcode; @@ -116,6 +142,7 @@ Record hashExport {A:Type}:= { 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 ****) diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml index c421ff87..b7a80679 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -1,7 +1,21 @@ open ImpPrelude exception Stop;; - + +let make_dict (type key) (p: key Dict.hash_params) = + let module MyHashedType = struct + type t = key + let equal = p.Dict.test_eq + let hash = p.Dict.hashing + end in + let module MyHashtbl = Hashtbl.Make(MyHashedType) in + let dict = MyHashtbl.create 1000 in + { + Dict.set = (fun (k,d) -> MyHashtbl.replace dict k d); + Dict.get = (fun k -> MyHashtbl.find_opt dict k) + } + + let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) = let module MyHashedType = struct type t = a pre_hashV diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli index e81681df..a74c721a 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -1,3 +1,4 @@ open ImpPrelude +val make_dict : 'a1 Dict.hash_params -> ('a1, 'a2) Dict.t val xhCons: (('a -> 'a -> bool) * ('a pre_hashV -> 'a hashV)) -> 'a hashConsing -- cgit From d387e48b60ea313c5852b8166859fbdae34ecfef Mon Sep 17 00:00:00 2001 From: tvdd Date: Wed, 15 May 2019 10:06:44 +0200 Subject: m --- mppa_k1c/Machblockgenproof.v | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 1affe8d2..2d7e0632 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -466,6 +466,8 @@ Proof. inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. Qed. + + Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): trans_inst i = MB_basic bi -> Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> @@ -485,6 +487,7 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. + Lemma star_step_simu_body_step s f sp c bdy c': is_body bdy c c' -> forall rs m t s', starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> @@ -563,6 +566,13 @@ Proof. Qed. *) +Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: + trans_inst i = MB_cfi cfi -> + is_trans_code c blc -> + Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> + exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ t=E0 /\ match_states s' s2. +Proof. +Admitted. Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: is_exit e c c' -> is_trans_code c' blc -> @@ -580,14 +590,18 @@ Proof. - (* None *) intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). split; eauto. - Search trans_code. apply is_trans_code_inv in H0. rewrite H0. apply match_states_trans_state. - (* Some *) intros H0 H1. inversion H1; subst. - (* A FINIR *) + exploit (step_simu_cfi_step); eauto. + intro Hcfi. + destruct Hcfi as [s2 [Hcfi1 [Hcfi2 Hcfi3]]]. + inversion H4. subst; simpl. + exists s2. + split;eauto. Admitted. (* Inductive state : Type := -- cgit From d899f83728a04091bd60a43e774702f02fd59e28 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 15 May 2019 10:32:57 +0200 Subject: more lemmas on division --- mppa_k1c/ExtValues.v | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index e9b2610c..1eb0bb89 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -474,4 +474,58 @@ Proof. } } -*) \ No newline at end of file + *) + +Require Import Coq.ZArith.Zquot. +Lemma Z_quot_pos_pos_bound: forall a b m, + 0 <= a <= m -> 1 <= b -> 0 <= Z.quot a b <= m. +Proof. + intros. + split. + { rewrite <- (Z.quot_0_l b) by omega. + apply Z_quot_monotone; omega. + } + apply Z.le_trans with (m := a). + { + apply Z_quot_le; tauto. + } + tauto. +Qed. +Lemma Z_quot_neg_pos_bound: forall a b m, + m <= a <= 0 -> 1 <= b -> m <= Z.quot a b <= 0. + intros. + assert (0 <= - (a ÷ b) <= -m). + { + rewrite <- Z.quot_opp_l by omega. + apply Z_quot_pos_pos_bound; omega. + } + omega. +Qed. + +Lemma Z_quot_signed_pos_bound: forall a b, + Int.min_signed <= a <= Int.max_signed -> 1 <= b -> + Int.min_signed <= Z.quot a b <= Int.max_signed. +Proof. + intros. + destruct (Z_lt_ge_dec a 0). + { + split. + { apply Z_quot_neg_pos_bound; omega. } + { eapply Z.le_trans with (m := 0). + { apply Z_quot_neg_pos_bound with (m := Int.min_signed); trivial. + split. tauto. auto with zarith. + } + discriminate. + } + } + { split. + { eapply Z.le_trans with (m := 0). + discriminate. + apply Z_quot_pos_pos_bound with (m := Int.max_signed); trivial. + split. omega. tauto. + } + { apply Z_quot_pos_pos_bound; omega. + } + } +Qed. + -- cgit From 0b9b2e75d76a5871345f68af478d3cf4c14395ee Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 15 May 2019 11:02:02 +0200 Subject: more lemmas on division --- mppa_k1c/ExtValues.v | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 1eb0bb89..13d63610 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -529,3 +529,51 @@ Proof. } Qed. +Lemma Z_quot_signed_neg_bound: forall a b, + Int.min_signed <= a <= Int.max_signed -> b < -1 -> + Int.min_signed <= Z.quot a b <= Int.max_signed. +Proof. + change Int.min_signed with (-2147483648). + change Int.max_signed with 2147483647. + intros. + + replace b with (-(-b)) by auto with zarith. + rewrite Z.quot_opp_r by omega. + assert (-2147483647 <= (a ÷ - b) <= 2147483648). + 2: omega. + + destruct (Z_lt_ge_dec a 0). + { + replace a with (-(-a)) by auto with zarith. + rewrite Z.quot_opp_l by omega. + assert (-2147483648 <= - a ÷ - b <= 2147483647). + 2: omega. + split. + { + rewrite Z.quot_opp_l by omega. + assert (a ÷ - b <= 2147483648). + 2: omega. + { + apply Z.le_trans with (m := 0). + rewrite <- (Z.quot_0_l (-b)) by omega. + apply Z_quot_monotone; omega. + discriminate. + } + } + assert (- a ÷ - b < -a ). + 2: omega. + apply Z_quot_lt; omega. + } + { + split. + { apply Z.le_trans with (m := 0). + discriminate. + rewrite <- (Z.quot_0_l (-b)) by omega. + apply Z_quot_monotone; omega. + } + { apply Z.le_trans with (m := a). + apply Z_quot_le. + all: omega. + } + } +Qed. \ No newline at end of file -- cgit From 28557d104a06e001d7f4c9c51ad28abae5beadff Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 15 May 2019 11:12:40 +0200 Subject: detail --- mppa_k1c/ExtValues.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 13d63610..980e18f8 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -576,4 +576,4 @@ Proof. all: omega. } } -Qed. \ No newline at end of file +Qed. -- cgit From 237fdab9a172a7d96fe7e95f7f02ec30d6ac0ac2 Mon Sep 17 00:00:00 2001 From: tvdd Date: Wed, 15 May 2019 15:55:14 +0200 Subject: step_simu_cfi_step ?? --- mppa_k1c/Machblockgenproof.v | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 2d7e0632..6e1f183b 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -570,8 +570,36 @@ Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach trans_inst i = MB_cfi cfi -> is_trans_code c blc -> Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> - exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ t=E0 /\ match_states s' s2. + exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s' s2. Proof. + destruct i; simpl in * |-; + (intro H; intro Htc;apply is_trans_code_inv in Htc;rewrite Htc;inversion_clear H;intro X; inversion_clear X). + * eapply ex_intro. + intuition auto. + eapply exec_MBcall;eauto. + rewrite <-H; exploit (find_function_ptr_same); eauto. + * eapply ex_intro. + intuition auto. + eapply exec_MBtailcall;eauto. + - rewrite <-H; exploit (find_function_ptr_same); eauto. + - simpl; rewrite <- parent_sp_preserved; auto. + - simpl; rewrite <- parent_ra_preserved; auto. + * eapply ex_intro. + intuition auto. + eapply exec_MBbuiltin ;eauto. + * exploit find_label_preserved. eauto. + intro Hla. destruct Hla as [ h [Hla1 Hla2]]. + exists (trans_state (Mach.State stk f sp c' rs m)). + intuition auto. + eapply exec_MBgoto; eauto. + + +(* eapply ex_intro. + intuition auto. + eapply exec_MBcond_true;eauto. +*) + + Admitted. Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: @@ -598,11 +626,12 @@ Proof. inversion H1; subst. exploit (step_simu_cfi_step); eauto. intro Hcfi. - destruct Hcfi as [s2 [Hcfi1 [Hcfi2 Hcfi3]]]. + destruct Hcfi as [s2 [Hcfi1 Hcfi3]]. inversion H4. subst; simpl. + autorewrite with trace_rewrite. exists s2. split;eauto. -Admitted. +Qed. (* Inductive state : Type := State : list stackframe -> -- cgit From 2981acd39bb23b783339fa6848aa284bfae938c0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 15 May 2019 18:01:25 +0200 Subject: directly call float and double division from gcc lib instead of a stub --- mppa_k1c/TargetPrinter.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3c46ef16..15f05960 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -39,6 +39,8 @@ module Target (*: TARGET*) = | "__compcert_i64_sdiv" -> "__divdi3" | "__compcert_i64_umod" -> "__umoddi3" | "__compcert_i64_smod" -> "__moddi3" + | "__compcert_f64_div" -> "__divdf3" + | "__compcert_f32_div" -> "__divsf3" | x -> x;; let symbol oc symb = -- cgit From 271177a4df951407ef0aed295364d11e292b40e0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 16 May 2019 11:14:47 +0200 Subject: improving the scheduling verifier and its framework --- mppa_k1c/abstractbb/DepTreeTheory.v | 41 +++++++++- mppa_k1c/abstractbb/ImpDep.v | 144 +++++++++++++++++++++++++++--------- 2 files changed, 149 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v index 6646d4f5..c7bed8bf 100644 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ b/mppa_k1c/abstractbb/DepTreeTheory.v @@ -365,16 +365,51 @@ Proof. 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, pre (bblock_deps p1) ge m -> pre (bblock_deps p2) ge m) -> - (forall m0 x m1, pre (bblock_deps p1) ge m0 -> deps_eval ge (bblock_deps p1) x m0 = Some m1 -> + (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. - intros INCL EQUIV m DONTFAIL. + 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. diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v index 3efe6a36..eebf396d 100644 --- a/mppa_k1c/abstractbb/ImpDep.v +++ b/mppa_k1c/abstractbb/ImpDep.v @@ -136,7 +136,7 @@ Record hdeps:= {hpre: list (hashV tree); hpost: Dict.t (hashV tree)}. Coercion hpost: hdeps >-> Dict.t. (* pseudo deps_get *) -Definition pdeps_get (d:hdeps) x : tree := +Definition pdeps_get (d:Dict.t (hashV tree)) x : tree := match Dict.get d x with | None => Tname x | Some t => (data t) @@ -158,9 +158,25 @@ 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 <-> pre d ge m) - /\ (forall m x, tree_eval ge (pdeps_get hd x) m = deps_eval ge d x m). + (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 @@ -184,21 +200,22 @@ 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, tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. + 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, 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; try congruence. - - rewrite H4, <- H0; simpl; reflexivity. - - rewrite H1; simpl; reflexivity. - - rewrite H5, <- H0, <- H4; simpl; reflexivity. + 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 -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. + 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. @@ -221,29 +238,85 @@ Proof. Qed. Local Hint Resolve failsafe_correct. -Definition hdeps_set (d:hdeps) x (t:hashV tree) := - DO ot <~ hdeps_get d x None;; - RET {| hpre:=if failsafe (data ot) then d.(hpre) else ot::d.(hpre); - hpost:=Dict.set d x t |}. +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, tree_eval ge (data ht) m = tree_eval ge t m) -> (* TODO: condition à revoir, on peut sans doute relâcher ici ! *) + (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. - unfold deps_model, deps_set; simpl. destruct H0 as (DM0 & DM1); split. - - intros m; unfold hdeps_valid in DM0 |- *; simpl. - generalize (failsafe_correct ge (data exta) m); intros FAILSAFE. - destruct (DM0 m) as (H2 & H3); clear DM0. unfold deps_eval in * |- *. - destruct (failsafe _); simpl. - * rewrite !H, !DM1 in * |- *; intuition (subst; eauto). - * clear FAILSAFE. rewrite <- DM1, <- H. intuition (subst; eauto). - - clear H DM0. unfold deps_eval, pdeps_get, deps_get in * |- *; simpl. - intros; case (R.eq_dec x x0). - + intros; subst; rewrite !Dict.set_spec_eq; simpl; auto. - + intros; rewrite !Dict.set_spec_diff; simpl; auto. + 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. @@ -263,9 +336,10 @@ Fixpoint hinst_deps (i: inst) (d od: hdeps): ?? hdeps := 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 -> deps_model ge (inst_deps i d od) hd'. + 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. - induction i; simpl; wlp_simplify. + 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. @@ -298,8 +372,8 @@ 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, pdeps_get, hdeps_valid, deps_eval, deps_get; simpl. - intuition; rewrite !Dict.empty_spec; simpl; auto. + 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. @@ -427,8 +501,12 @@ Obligation 1. 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. - erewrite pdeps_get_intro; auto. auto. + + 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: -- cgit From 7cecc1acf0f32044d702aa9fc983eebb3f57f9fb Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 17 May 2019 12:07:51 +0200 Subject: Desactivating the "one instruction per bundle" failsafe --- mppa_k1c/PostpassSchedulingOracle.ml | 3 +++ 1 file changed, 3 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 39a14727..9067f8e1 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -872,8 +872,11 @@ let smart_schedule bb = Printf.eprintf "In regards to this group of instructions:\n"; print_bb stderr bb; Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; + failwith "Invalid schedule" + (* Printf.eprintf "Issuing one instruction per bundle instead\n\n"; dumb_schedule bb + *) end in bundles @ (f lbb) in f lbb -- cgit From 16e932213b7cad49e2942ae93434398cf4a72c59 Mon Sep 17 00:00:00 2001 From: tvdd Date: Fri, 17 May 2019 17:09:41 +0200 Subject: is_trans_code_monotonic proof --- mppa_k1c/Machblockgenproof.v | 176 +++++++++++++++++++++++++++++-------------- 1 file changed, 120 insertions(+), 56 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 6e1f183b..f0618cfe 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -527,45 +527,6 @@ Proof. + intros H r; constructor 1; intro X; inversion X. Qed. -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? -Lemma step_simu_cfi_step: - forall c e c' stk f sp rs m t s' b lb', - to_bblock_exit c = (Some e, c') -> - trans_code c' = lb' -> - Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp c rs m) t s' -> - exists s2, cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t s2 /\ match_states s' s2. -Proof. - intros c e c' stk f sp rs m t s' b lb'. - intros Hexit Htc Hstep. - destruct c as [|ei c]; try (contradict Hexit; discriminate). - destruct ei; (contradict Hexit; discriminate) || ( - inversion Hexit; subst; inversion Hstep; subst; simpl - ). - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - apply exec_MBcall with (f := (transf_function f0)); auto. - rewrite find_function_ptr_same in H9; auto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - apply exec_MBtailcall with (f := (transf_function f0)); auto. - rewrite find_function_ptr_same in H9; auto. - rewrite parent_sp_preserved in H11; subst; auto. - rewrite parent_ra_preserved in H12; subst; auto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBbuiltin; eauto. - * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBcond_false; eauto. - * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBreturn; eauto. - rewrite parent_sp_preserved in H8; subst; auto. - rewrite parent_ra_preserved in H9; subst; auto. -Qed. -*) - Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: trans_inst i = MB_cfi cfi -> is_trans_code c blc -> @@ -587,20 +548,21 @@ Proof. * eapply ex_intro. intuition auto. eapply exec_MBbuiltin ;eauto. - * exploit find_label_preserved. eauto. - intro Hla. destruct Hla as [ h [Hla1 Hla2]]. - exists (trans_state (Mach.State stk f sp c' rs m)). - intuition auto. - eapply exec_MBgoto; eauto. - - -(* eapply ex_intro. - intuition auto. - eapply exec_MBcond_true;eauto. -*) - - -Admitted. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBcond_false; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBreturn; eauto. + rewrite parent_sp_preserved in H0; subst; auto. + rewrite parent_ra_preserved in H1; subst; auto. +Qed. Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: is_exit e c c' -> is_trans_code c' blc -> @@ -632,6 +594,7 @@ Proof. exists s2. split;eauto. Qed. + (* Inductive state : Type := State : list stackframe -> @@ -724,12 +687,95 @@ Qed. Axiom TODO: False. (* A ELIMINER *) +Lemma t' i c: + exists bl, + trans_code_rev (rev_append c (i :: nil)) nil = + trans_code_rev (i :: nil) bl. +Proof. + exists (trans_code_rev c nil). + induction c; eauto. + simpl in IHc. + simpl. + unfold trans_code_rev. + (* TODO *) +Admitted. + +Lemma cfi_dist_end_block i c: (* TODO: raccourcir *) +(exists cfi, trans_inst i = MB_cfi cfi) -> +dist_end_block_code (i :: c) = 0. +Proof. + pose t'. + intro H. destruct H as [cfi H]. + destruct i;simpl in H;try(congruence). + + destruct (e (Mcall s s0) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mtailcall s s0 ) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mbuiltin e0 l b ) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mgoto l) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mcond c0 l l0 ) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mjumptable m l) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. + + destruct (e (Mreturn) c) as [bl Ht]. + unfold dist_end_block_code, trans_code; simpl. + rewrite Ht. + unfold trans_code_rev, add_to_code; simpl. + destruct bl; vm_compute; eauto. +Qed. + Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) - - intros s1 t s1' H1. elim TODO. (* A FAIRE *) + (* TODO: simplifier *) + - intros s1 t s1' H1. + destruct H1; simpl; omega || (intuition auto). + + cutrewrite (dist_end_block_code (Mcall sig ros :: c)=0) in H2. + destruct H2; eauto. + apply cfi_dist_end_block; exists (MBcall sig ros); simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mtailcall sig ros :: c)=0) in H4. + destruct H4; eauto. + apply cfi_dist_end_block; exists (MBtailcall sig ros ); simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mbuiltin ef args res :: b)=0) in H2. + destruct H2; eauto. + apply cfi_dist_end_block; exists (MBbuiltin ef args res); simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mgoto lbl :: c)=0) in H1. + destruct H1; eauto. + apply cfi_dist_end_block; exists (MBgoto lbl); simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mcond cond args lbl :: c)=0) in H3. + destruct H3; eauto. + apply cfi_dist_end_block; exists (MBcond cond args lbl) ; simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mjumptable arg tbl :: c)=0) in H4. + destruct H4; eauto. + apply cfi_dist_end_block; exists (MBjumptable arg tbl) ; simpl; reflexivity. + + cutrewrite (dist_end_block_code (Mreturn :: c)=0) in H3. + destruct H3; eauto. + apply cfi_dist_end_block; exists (MBreturn) ; simpl; reflexivity. + (*unfold dist_end_block_code, trans_code, trans_code_rev, add_to_code. + unfold size,add_to_new_bblock, add_label, add_basic. unfold cfi_bblock. simpl.*) + (*elim TODO.*) (* A FAIRE *) (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? destruct H1; simpl; omega || (intuition auto). *) @@ -758,9 +804,9 @@ Qed. End PRESERVATION. +(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) -(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) Lemma is_trans_code_monotonic i c b l: is_trans_code c (b::l) -> @@ -771,7 +817,25 @@ Proof. destruct ti as [lbl|bi|cfi]. - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2:{ destruct i; simpl in * |- *; try congruence. } exists nil; simpl; eexists. eapply Tr_add_label; eauto. -Admitted. (* A FINIR *) + - (*i=basic*) + destruct i'. + 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. + rewrite <-Heqti. + eapply End_basic. inversion H; try(simpl; congruence). + simpl in H5; congruence. } + all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). + - (*i=cfi*) + destruct i; try(simpl in Heqti; congruence). + all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; + cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; + rewrite Heqti; + eapply Tr_end_block; eauto; + rewrite <-Heqti; + eapply End_cfi; congruence. +Qed. Lemma trans_code_monotonic i c b l: (b::l) = trans_code c -> -- cgit From 1153ff98a18c1730b17444ce3dc4953b886cf9f0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 20 May 2019 10:23:43 +0200 Subject: m --- mppa_k1c/Machblockgenproof.v | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index f0618cfe..64eeadbc 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -704,10 +704,16 @@ Lemma cfi_dist_end_block i c: (* TODO: raccourcir *) (exists cfi, trans_inst i = MB_cfi cfi) -> dist_end_block_code (i :: c) = 0. Proof. - pose t'. + unfold dist_end_block_code. intro H. destruct H as [cfi H]. - destruct i;simpl in H;try(congruence). - + destruct (e (Mcall s s0) c) as [bl Ht]. + destruct i;simpl in H;try(congruence); ( + remember (trans_code _) as bl; + rewrite <- is_trans_code_inv in Heqbl; + inversion Heqbl; subst; simpl in * |- *; try (reflexivity || congruence)). +Qed. +(* + - simpl. + destruct (e (Mcall s s0) c) as [bl Ht]. unfold dist_end_block_code, trans_code; simpl. rewrite Ht. unfold trans_code_rev, add_to_code; simpl. @@ -743,7 +749,7 @@ Proof. unfold trans_code_rev, add_to_code; simpl. destruct bl; vm_compute; eauto. Qed. - +*) Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. -- cgit From b3c52c2d0bd4e4bbc2a32afdf6e8786c0bd530ac Mon Sep 17 00:00:00 2001 From: tvdd Date: Mon, 20 May 2019 11:22:17 +0200 Subject: transf_program_correct proof --- mppa_k1c/Machblockgenproof.v | 98 ++++---------------------------------------- 1 file changed, 7 insertions(+), 91 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 64eeadbc..1ee2edc0 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -595,29 +595,6 @@ Proof. split;eauto. Qed. -(* -Inductive state : Type := - State : list stackframe -> - block -> val -> code -> regset -> mem -> state - | Callstate : list stackframe -> block -> regset -> mem -> state - | Returnstate : list stackframe -> regset -> mem -> state -*) - -(* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? -Proof. - intros H1 H2; destruct e as [ e |]; inversion_clear H2. - + (* Some *) inversion H0; clear H0; subst. autorewrite with trace_rewrite. - exploit step_simu_cfi_step; eauto. - intros (s2' & H2 & H3); eapply ex_intro; intuition eauto. - + (* None *) - destruct c as [ |i c]; simpl in H1; inversion H1. - - eapply ex_intro; intuition eauto; try eapply match_states_trans_state. - - remember to_cfi as o. destruct o; try discriminate. - inversion_clear H1. - eapply ex_intro; intuition eauto; try eapply match_states_trans_state. -Qed. -*) - Lemma simu_end_block: forall s1 t s1', starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> @@ -685,22 +662,8 @@ Proof. eapply exec_return. Qed. -Axiom TODO: False. (* A ELIMINER *) - -Lemma t' i c: - exists bl, - trans_code_rev (rev_append c (i :: nil)) nil = - trans_code_rev (i :: nil) bl. -Proof. - exists (trans_code_rev c nil). - induction c; eauto. - simpl in IHc. - simpl. - unfold trans_code_rev. - (* TODO *) -Admitted. -Lemma cfi_dist_end_block i c: (* TODO: raccourcir *) +Lemma cfi_dist_end_block i c: (exists cfi, trans_inst i = MB_cfi cfi) -> dist_end_block_code (i :: c) = 0. Proof. @@ -711,53 +674,14 @@ Proof. rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; subst; simpl in * |- *; try (reflexivity || congruence)). Qed. -(* - - simpl. - destruct (e (Mcall s s0) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mtailcall s s0 ) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mbuiltin e0 l b ) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mgoto l) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mcond c0 l l0 ) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mjumptable m l) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. - + destruct (e (Mreturn) c) as [bl Ht]. - unfold dist_end_block_code, trans_code; simpl. - rewrite Ht. - unfold trans_code_rev, add_to_code; simpl. - destruct bl; vm_compute; eauto. -Qed. -*) + Theorem transf_program_correct: forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). Proof. apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) - (* TODO: simplifier *) - intros s1 t s1' H1. - destruct H1; simpl; omega || (intuition auto). + destruct H1; simpl; omega || (intuition auto). + cutrewrite (dist_end_block_code (Mcall sig ros :: c)=0) in H2. destruct H2; eauto. apply cfi_dist_end_block; exists (MBcall sig ros); simpl; reflexivity. @@ -779,12 +703,6 @@ Proof. + cutrewrite (dist_end_block_code (Mreturn :: c)=0) in H3. destruct H3; eauto. apply cfi_dist_end_block; exists (MBreturn) ; simpl; reflexivity. - (*unfold dist_end_block_code, trans_code, trans_code_rev, add_to_code. - unfold size,add_to_new_bblock, add_label, add_basic. unfold cfi_bblock. simpl.*) - (*elim TODO.*) (* A FAIRE *) - (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? - destruct H1; simpl; omega || (intuition auto). - *) (* public_preserved *) - apply senv_preserved. (* match_initial_states *) @@ -797,13 +715,11 @@ Proof. (* match_final_states *) - intros. simpl. destruct H. split with (r := r); auto. (* final_states_end_block *) - - intros. simpl in H0. elim TODO. - (* VIELLE PREUVE -- UTILE POUR S'INSPIRER ??? + - intros. simpl in H0. inversion H0. - inversion H; simpl; auto. - (* the remaining instructions cannot lead to a Returnstate *) - all: subst; discriminate. - *) + inversion H; simpl; auto. + all: try (subst; discriminate). + apply cfi_dist_end_block; exists MBreturn; eauto. (* simu_end_block *) - apply simu_end_block. Qed. -- cgit From f1d4b55d556922ff36329b5df71e714cd3fb1e08 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 20 May 2019 15:52:48 +0200 Subject: legere simplification de preuve --- mppa_k1c/Machblockgenproof.v | 36 +++++++----------------------------- 1 file changed, 7 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v index 1ee2edc0..9186e54a 100644 --- a/mppa_k1c/Machblockgenproof.v +++ b/mppa_k1c/Machblockgenproof.v @@ -499,7 +499,7 @@ Proof. + intros. inversion H1; subst. exploit (step_simu_basic_step ); eauto. destruct 1 as [ rs1 [ m1 Hs]]. - destruct Hs as [Hs1 [Hs2 Hs3]]. + destruct Hs as [Hs1 [Hs2 Hs3]]. destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. exists rs2, m2. @@ -569,11 +569,10 @@ Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. Proof. - destruct 1. + destruct 1. - (* None *) intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). split; eauto. - Search trans_code. apply is_trans_code_inv in H0. rewrite H0. apply match_states_trans_state. @@ -587,8 +586,7 @@ Proof. intros H0 H1. inversion H1; subst. exploit (step_simu_cfi_step); eauto. - intro Hcfi. - destruct Hcfi as [s2 [Hcfi1 Hcfi3]]. + intros [s2 [Hcfi1 Hcfi3]]. inversion H4. subst; simpl. autorewrite with trace_rewrite. exists s2. @@ -672,7 +670,7 @@ Proof. destruct i;simpl in H;try(congruence); ( remember (trans_code _) as bl; rewrite <- is_trans_code_inv in Heqbl; - inversion Heqbl; subst; simpl in * |- *; try (reflexivity || congruence)). + inversion Heqbl; subst; simpl in * |- *; try (congruence)). Qed. Theorem transf_program_correct: @@ -680,29 +678,9 @@ Theorem transf_program_correct: Proof. apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). (* simu_mid_block *) - - intros s1 t s1' H1. - destruct H1; simpl; omega || (intuition auto). - + cutrewrite (dist_end_block_code (Mcall sig ros :: c)=0) in H2. - destruct H2; eauto. - apply cfi_dist_end_block; exists (MBcall sig ros); simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mtailcall sig ros :: c)=0) in H4. - destruct H4; eauto. - apply cfi_dist_end_block; exists (MBtailcall sig ros ); simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mbuiltin ef args res :: b)=0) in H2. - destruct H2; eauto. - apply cfi_dist_end_block; exists (MBbuiltin ef args res); simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mgoto lbl :: c)=0) in H1. - destruct H1; eauto. - apply cfi_dist_end_block; exists (MBgoto lbl); simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mcond cond args lbl :: c)=0) in H3. - destruct H3; eauto. - apply cfi_dist_end_block; exists (MBcond cond args lbl) ; simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mjumptable arg tbl :: c)=0) in H4. - destruct H4; eauto. - apply cfi_dist_end_block; exists (MBjumptable arg tbl) ; simpl; reflexivity. - + cutrewrite (dist_end_block_code (Mreturn :: c)=0) in H3. - destruct H3; eauto. - apply cfi_dist_end_block; exists (MBreturn) ; simpl; reflexivity. + - intros s1 t s1' H1 H2. + destruct H1; simpl in * |- *; omega || (intuition auto); + destruct H2; eapply cfi_dist_end_block; simpl; eauto. (* public_preserved *) - apply senv_preserved. (* match_initial_states *) -- cgit From 405847450b9464c899a16bc8ef6a752a58ab34e0 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 21 May 2019 16:26:43 +0200 Subject: move Machblock*.v into mppa_k1c/lib Indeed, these files may not be specific to our backend. --- mppa_k1c/Machblock.v | 355 ----------------- mppa_k1c/Machblockgen.v | 207 ---------- mppa_k1c/Machblockgenproof.v | 806 --------------------------------------- mppa_k1c/lib/Machblock.v | 355 +++++++++++++++++ mppa_k1c/lib/Machblockgen.v | 207 ++++++++++ mppa_k1c/lib/Machblockgenproof.v | 806 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 1368 insertions(+), 1368 deletions(-) delete mode 100644 mppa_k1c/Machblock.v delete mode 100644 mppa_k1c/Machblockgen.v delete mode 100644 mppa_k1c/Machblockgenproof.v create mode 100644 mppa_k1c/lib/Machblock.v create mode 100644 mppa_k1c/lib/Machblockgen.v create mode 100644 mppa_k1c/lib/Machblockgenproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v deleted file mode 100644 index 30393fd5..00000000 --- a/mppa_k1c/Machblock.v +++ /dev/null @@ -1,355 +0,0 @@ -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. - -(** instructions "basiques" (ie non 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 - | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst - . - -Definition bblock_body := list basic_inst. - -(** instructions de control flow *) -Inductive control_flow_inst: Type := - | MBcall: signature -> mreg + ident -> control_flow_inst - | MBtailcall: signature -> mreg + ident -> control_flow_inst - | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst - | MBgoto: label -> control_flow_inst - | MBcond: condition -> list mreg -> label -> control_flow_inst - | MBjumptable: mreg -> list label -> control_flow_inst - | MBreturn: control_flow_inst - . - -Record bblock := mk_bblock { - header: list label; - body: bblock_body; - exit: option control_flow_inst -}. - -Lemma bblock_eq: - forall b1 b2, - header b1 = header b2 -> - body b1 = body b2 -> - exit b1 = exit b2 -> - b1 = b2. -Proof. - intros. destruct b1. destruct b2. - simpl in *. subst. auto. -Qed. - -Definition length_opt {A} (o: option A) : nat := - match o with - | Some o => 1 - | None => 0 - end. - -Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). - -Lemma size_null b: - size b = 0%nat -> - header b = nil /\ body b = nil /\ exit b = None. -Proof. - destruct b as [h b e]. simpl. unfold size. simpl. - intros H. - assert (length h = 0%nat) as Hh; [ omega |]. - assert (length b = 0%nat) as Hb; [ omega |]. - assert (length_opt e = 0%nat) as He; [ omega|]. - repeat split. - destruct h; try (simpl in Hh; discriminate); auto. - destruct b; try (simpl in Hb; discriminate); auto. - destruct e; try (simpl in He; discriminate); auto. -Qed. - -Definition code := list bblock. - -Record function: Type := mkfunction - { fn_sig: signature; - fn_code: code; - fn_stacksize: Z; - fn_link_ofs: ptrofs; - fn_retaddr_ofs: ptrofs }. - -Definition fundef := AST.fundef function. - -Definition program := AST.program fundef unit. - -Definition genv := Genv.t fundef unit. - -(*** sémantique ***) - -Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. -Proof. - apply List.in_dec. - apply Pos.eq_dec. -Qed. - -Definition is_label (lbl: label) (bb: bblock) : bool := - if in_dec lbl (header bb) then true else false. - -Lemma is_label_correct_true lbl bb: - List.In lbl (header bb) <-> is_label lbl bb = true. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - -Lemma is_label_correct_false lbl bb: - ~(List.In lbl (header bb)) <-> is_label lbl bb = false. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - - -Local Open Scope nat_scope. - -Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Section RELSEM. - -Variable rao:function -> code -> ptrofs -> Prop. -Variable ge:genv. - -Definition find_function_ptr - (ge: genv) (ros: mreg + ident) (rs: regset) : option block := - match ros with - | inl r => - match rs r with - | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None - | _ => None - end - | inr symb => - Genv.find_symbol ge symb - end. - -(** Machblock execution states. *) - -Inductive stackframe: Type := - | Stackframe: - forall (f: block) (**r pointer to calling function *) - (sp: val) (**r stack pointer in calling function *) - (retaddr: val) (**r Asm return address in calling function *) - (c: code), (**r program point in calling function *) - stackframe. - -Inductive state: Type := - | State: - forall (stack: list stackframe) (**r call stack *) - (f: block) (**r pointer to current function *) - (sp: val) (**r stack pointer *) - (c: code) (**r current program point *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state - | Callstate: - forall (stack: list stackframe) (**r call stack *) - (f: block) (**r pointer to function to call *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state - | Returnstate: - forall (stack: list stackframe) (**r call stack *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state. - -Definition parent_sp (s: list stackframe) : val := - match s with - | nil => Vnullptr - | Stackframe f sp ra c :: s' => sp - end. - -Definition parent_ra (s: list stackframe) : val := - match s with - | nil => Vnullptr - | Stackframe f sp ra c :: s' => ra - end. - -Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := - | exec_MBgetstack: - forall ofs ty dst v, - load_stack m sp ty ofs = Some v -> - basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m - | exec_MBsetstack: - forall src ofs ty m' rs', - store_stack m sp ty ofs (rs src) = Some m' -> - rs' = undef_regs (destroyed_by_setstack ty) rs -> - basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' - | exec_MBgetparam: - forall ofs ty dst v rs' f, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (parent_sp s) ty ofs = Some v -> - rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> - basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m - | exec_MBop: - forall op args v rs' res, - eval_operation ge sp op rs##args m = Some v -> - 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, - 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 - | exec_MBstore: - forall chunk addr args src m' a rs', - eval_addressing ge sp addr rs##args = Some a -> - Mem.storev chunk m a (rs src) = Some m' -> - rs' = undef_regs (destroyed_by_store chunk addr) rs -> - basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' - . - - -Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := - | exec_nil_body: - forall rs m, - body_step s f sp nil rs m rs m - | exec_cons_body: - forall rs m bi p rs' m' rs'' m'', - basic_step s f sp rs m bi rs' m' -> - body_step s f sp p rs' m' rs'' m'' -> - body_step s f sp (bi::p) rs m rs'' m'' - . - -Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := - | exec_MBcall: - forall s fb sp sig ros c b rs m f f' ra, - find_function_ptr ge ros rs = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - rao f c ra -> - cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) - E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) - f' rs m) - | exec_MBtailcall: - forall s fb stk soff sig ros c rs m f f' m', - find_function_ptr ge ros rs = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) - E0 (Callstate s f' rs m') - | exec_MBbuiltin: - forall s f sp rs m ef args res b c vargs t vres rs' m', - eval_builtin_args ge rs sp m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> - cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) - t (State s f sp c rs' m') - | exec_MBgoto: - forall s fb f sp lbl c rs m c', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - cfi_step (MBgoto lbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs m) - | exec_MBcond_true: - forall s fb f sp cond args lbl c rs m c' rs', - eval_condition cond rs##args m = Some true -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - rs' = undef_regs (destroyed_by_cond cond) rs -> - cfi_step (MBcond cond args lbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs' m) - | exec_MBcond_false: - forall s f sp cond args lbl b c rs m rs', - eval_condition cond rs##args m = Some false -> - rs' = undef_regs (destroyed_by_cond cond) rs -> - cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) - E0 (State s f sp c rs' m) - | exec_MBjumptable: - forall s fb f sp arg tbl c rs m n lbl c' rs', - rs arg = Vint n -> - list_nth_z tbl (Int.unsigned n) = Some lbl -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - rs' = undef_regs destroyed_by_jumptable rs -> - cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs' m) - | exec_MBreturn: - forall s fb stk soff c rs m f m', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) - E0 (Returnstate s rs m') - . - -Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := - | exec_Some_exit: - forall ctl s t s', - cfi_step ctl s t s' -> - exit_step (Some ctl) s t s' - | exec_None_exit: - forall stk f sp b lb rs m, - exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) - . - -Inductive step: state -> trace -> state -> Prop := - | exec_bblock: - forall sf f sp bb c rs m rs' m' t s', - body_step sf f sp (body bb) rs m rs' m' -> - exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> - step (State sf f sp (bb::c) rs m) t s' - | exec_function_internal: - forall s fb rs m f m1 m2 m3 stk rs', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - let sp := Vptr stk Ptrofs.zero in - store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> - store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> - rs' = undef_regs destroyed_at_function_entry rs -> - step (Callstate s fb rs m) - E0 (State s fb sp f.(fn_code) rs' m3) - | exec_function_external: - forall s fb rs m t rs' ef args res m', - Genv.find_funct_ptr ge fb = Some (External ef) -> - extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> - external_call ef ge args m t res m' -> - rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> - step (Callstate s fb rs m) - t (Returnstate s rs' m') - | exec_return: - forall s f sp ra c rs m, - step (Returnstate (Stackframe f sp ra c :: s) rs m) - E0 (State s f sp c rs m) - . - -End RELSEM. - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall fb m0, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some fb -> - initial_state p (Callstate nil fb (Regmap.init Vundef) m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r retcode, - loc_result signature_main = One r -> - rs r = Vint retcode -> - final_state (Returnstate nil rs m) retcode. - -Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := - Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v deleted file mode 100644 index 4dfc309e..00000000 --- a/mppa_k1c/Machblockgen.v +++ /dev/null @@ -1,207 +0,0 @@ -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. -Require Import Machblock. - -Inductive Machblock_inst: Type := -| MB_label (lbl: label) -| MB_basic (bi: basic_inst) -| MB_cfi (cfi: control_flow_inst). - -Definition trans_inst (i:Mach.instruction) : Machblock_inst := - match i with - | Mcall sig ros => MB_cfi (MBcall sig ros) - | Mtailcall sig ros => MB_cfi (MBtailcall sig ros) - | Mbuiltin ef args res => MB_cfi (MBbuiltin ef args res) - | Mgoto lbl => MB_cfi (MBgoto lbl) - | Mcond cond args lbl => MB_cfi (MBcond cond args lbl) - | Mjumptable arg tbl => MB_cfi (MBjumptable arg tbl) - | Mreturn => MB_cfi (MBreturn) - | Mgetstack ofs ty dst => MB_basic (MBgetstack ofs ty dst) - | 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) - | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) - | Mlabel l => MB_label l - end. - -Definition empty_bblock:={| header := nil; body := nil; exit := None |}. -Extraction Inline empty_bblock. - -Definition add_label l bb:={| header := l::(header bb); body := (body bb); exit := (exit bb) |}. -Extraction Inline add_label. - -Definition add_basic bi bb :={| header := nil; body := bi::(body bb); exit := (exit bb) |}. -Extraction Inline add_basic. - -Definition cfi_bblock cfi:={| header := nil; body := nil; exit := Some cfi |}. -Extraction Inline cfi_bblock. - -Definition add_to_new_bblock (i:Machblock_inst) : bblock := - match i with - | MB_label l => add_label l empty_bblock - | MB_basic i => add_basic i empty_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)*) -Definition add_to_code (i:Machblock_inst) (bl:code) : code := - match bl with - | bh::bl0 => match i with - | MB_label l => add_label l bh::bl0 - | MB_cfi i0 => cfi_bblock i0::bl - | MB_basic i0 => match header bh with - |_::_ => add_basic i0 empty_bblock::bl - | nil => add_basic i0 bh::bl0 - end - end - | _ => add_to_new_bblock i::nil - end. - -Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := - match c with - | nil => bl - | i::c0 => - trans_code_rev c0 (add_to_code (trans_inst i) bl) - end. - -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); - fn_stacksize := Mach.fn_stacksize f; - fn_link_ofs := Mach.fn_link_ofs f; - fn_retaddr_ofs := Mach.fn_retaddr_ofs f - |}. - -Definition transf_fundef (f: Mach.fundef) : fundef := - transf_fundef transf_function f. - -Definition transf_program (src: Mach.program) : program := - transform_program transf_fundef src. - - -(** Abstraction de 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. - -Inductive is_trans_code: Mach.code -> code -> Prop := - | Tr_nil: is_trans_code nil nil - | Tr_end_block i c bl: - is_trans_code c bl -> - is_end_block (trans_inst i) bl -> - is_trans_code (i::c) (add_to_new_bblock (trans_inst i)::bl) - | Tr_add_label i l bh c bl: - is_trans_code c (bh::bl) -> - i = Mlabel l -> - is_trans_code (i::c) (add_label l bh::bl) - | Tr_add_basic i bi bh c bl: - is_trans_code c (bh::bl) -> - trans_inst i = MB_basic bi -> - header bh = nil -> - is_trans_code (i::c) (add_basic bi bh::bl). - -Local Hint Resolve Tr_nil Tr_end_block. - -Lemma add_to_code_is_trans_code i c bl: - is_trans_code c bl -> - is_trans_code (i::c) (add_to_code (trans_inst i) bl). -Proof. - destruct bl as [|bh0 bl]; simpl. - - intro H. inversion H. subst. eauto. - - remember (trans_inst i) as ti. - destruct ti as [l|bi|cfi]. - + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. - + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. - * eapply Tr_add_basic; eauto. - * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. - rewrite Heqti; eapply Tr_end_block; eauto. - rewrite <- Heqti. eapply End_basic. congruence. - + intros. - cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. - rewrite Heqti. eapply Tr_end_block; eauto. - rewrite <- Heqti. eapply End_cfi. congruence. -Qed. - -Local Hint Resolve add_to_code_is_trans_code. - -Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, - is_trans_code c2 mbi -> - is_trans_code (rev_append c1 c2) (trans_code_rev c1 mbi). -Proof. - induction c1 as [| i c1]; simpl; auto. -Qed. - -Lemma trans_code_is_trans_code c: is_trans_code c (trans_code c). -Proof. - unfold trans_code. - rewrite <- rev_alt. - rewrite <- (rev_involutive c) at 1. - rewrite rev_alt at 1. - apply trans_code_is_trans_code_rev; auto. -Qed. - -Lemma add_to_code_is_trans_code_inv i c bl: - is_trans_code (i::c) bl -> exists bl0, is_trans_code c bl0 /\ bl = add_to_code (trans_inst i) bl0. -Proof. - intro H; inversion H as [|H0 H1 bl0| | H0 bi bh H1 bl0]; clear H; subst; (repeat econstructor); eauto. - + (* case Tr_end_block *) inversion H3; subst; simpl; auto. - * destruct (header bh); congruence. - * destruct bl0; simpl; congruence. - + (* case Tr_add_basic *) rewrite H3. simpl. destruct (header bh); congruence. -Qed. - -Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, - is_trans_code (rev_append c1 c2) mbi -> - exists mbi0, is_trans_code c2 mbi0 /\ mbi=trans_code_rev c1 mbi0. -Proof. - induction c1 as [| i c1]; simpl; eauto. - intros; exploit IHc1; eauto. - intros (mbi0 & H1 & H2); subst. - exploit add_to_code_is_trans_code_inv; eauto. - intros. destruct H0 as [mbi1 [H2 H3]]. - exists mbi1. split; congruence. -Qed. - -Local Hint Resolve trans_code_is_trans_code. - -Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). -Proof. - constructor; intros; subst; auto. - unfold trans_code. - exploit (trans_code_is_trans_code_rev_inv (rev_append c nil) nil bl); eauto. - * rewrite <- rev_alt. - rewrite <- rev_alt. - rewrite (rev_involutive c). - apply H. - * intros. - destruct H0 as [mbi [H0 H1]]. - inversion H0. subst. reflexivity. -Qed. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v deleted file mode 100644 index 9186e54a..00000000 --- a/mppa_k1c/Machblockgenproof.v +++ /dev/null @@ -1,806 +0,0 @@ -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. -Require Import Machblock. -Require Import Machblockgen. -Require Import ForwardSimulationBlock. - -Ltac subst_is_trans_code H := - rewrite is_trans_code_inv in H; - rewrite <- H in * |- *; - rewrite <- is_trans_code_inv in H. - -Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := - rao (transf_function f) (trans_code c). - -Definition match_prog (p: Mach.program) (tp: Machblock.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. - -Definition trans_stackframe (msf: Mach.stackframe) : stackframe := - match msf with - | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) - end. - -Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := - match mst with - | nil => nil - | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) - end. - -Definition trans_state (ms: Mach.state): state := - match ms with - | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m - | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m - | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m - end. - -Section PRESERVATION. - -Local Open Scope nat_scope. - -Variable prog: Mach.program. -Variable tprog: Machblock.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - - -Variable rao: function -> code -> ptrofs -> Prop. - -Definition match_states: Mach.state -> state -> Prop - := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. - -Lemma match_states_trans_state s1: match_states s1 (trans_state s1). -Proof. - apply match_states_trans_state. -Qed. - -Local Hint Resolve match_states_trans_state. - -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 init_mem_preserved: - forall m, - Genv.init_mem prog = Some m -> - Genv.init_mem tprog = Some m. -Proof (Genv.init_mem_transf TRANSF). - -Lemma prog_main_preserved: - prog_main tprog = prog_main prog. -Proof (match_program_main 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 = tf. -Proof. - intros. - exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. - destruct H0 as (cunit & tf & A & B & C). - eapply ex_intro. intuition; eauto. subst. eapply A. -Qed. - -Lemma find_function_ptr_same: - forall s rs, - Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. -Proof. - intros. unfold Mach.find_function_ptr. unfold find_function_ptr. - destruct s; auto. - rewrite symbols_preserved; auto. -Qed. - -Lemma find_funct_ptr_same: - forall f f0, - Genv.find_funct_ptr ge f = Some (Internal f0) -> - Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). -Proof. - intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. -Qed. - -Lemma find_funct_ptr_same_external: - forall f f0, - Genv.find_funct_ptr ge f = Some (External f0) -> - Genv.find_funct_ptr tge f = Some (External f0). -Proof. - intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. -Qed. - -Lemma parent_sp_preserved: - forall s, - Mach.parent_sp s = parent_sp (trans_stack s). -Proof. - unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. - unfold trans_stackframe. destruct s; simpl; auto. -Qed. - -Lemma parent_ra_preserved: - forall s, - Mach.parent_ra s = parent_ra (trans_stack s). -Proof. - unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. - unfold trans_stackframe. destruct s; simpl; auto. -Qed. - -Lemma external_call_preserved: - forall ef args m t res m', - external_call ef ge args m t res m' -> - external_call ef tge args m t res m'. -Proof. - intros. eapply external_call_symbols_preserved; eauto. - apply senv_preserved. -Qed. - -Lemma Mach_find_label_split l i c c': - Mach.find_label l (i :: c) = Some c' -> - (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). -Proof. - intros H. - destruct i; try (constructor 2; split; auto; discriminate ). - destruct (peq l0 l) as [P|P]. - - constructor. subst l0; split; auto. - revert H. unfold Mach.find_label. simpl. rewrite peq_true. - intros H; injection H; auto. - - constructor 2. split. - + intro F. injection F. intros. contradict P; auto. - + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. -Qed. - -Lemma find_label_is_end_block_not_label i l c bl: - is_end_block (trans_inst i) bl -> - is_trans_code c bl -> - i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. -Proof. - intros H H0 H1. - unfold find_label. - remember (is_label l _) as b. - cutrewrite (b = false); auto. - subst; unfold is_label. - destruct i; simpl in * |- *; try (destruct (in_dec l nil); intuition). - inversion H. - destruct (in_dec l (l0::nil)) as [H6|H6]; auto. - simpl in H6; intuition try congruence. -Qed. - -Lemma find_label_at_begin l bh bl: - In l (header bh) - -> find_label l (bh :: bl) = Some (bh::bl). -Proof. - unfold find_label; rewrite is_label_correct_true; intro H; rewrite H; simpl; auto. -Qed. - -Lemma find_label_add_label_diff l bh bl: - ~(In l (header bh)) -> - find_label l (bh::bl) = find_label l bl. -Proof. - unfold find_label; rewrite is_label_correct_false; intro H; rewrite H; simpl; auto. -Qed. - -Definition concat (h: list label) (c: code): code := - match c with - | nil => {| header := h; body := nil; exit := None |}::nil - | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' - end. - -Lemma find_label_transcode_preserved: - forall l c c', - Mach.find_label l c = Some c' -> - exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). -Proof. - intros l c. remember (trans_code _) as bl. - rewrite <- is_trans_code_inv in * |-. - induction Heqbl. - + (* Tr_nil *) - intros; exists (l::nil); simpl in * |- *; intuition. - discriminate. - + (* Tr_end_block *) - intros. - exploit Mach_find_label_split; eauto. - clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. rewrite find_label_at_begin; simpl; auto. - inversion H as [mbi H1 H2| | ]. - subst. - inversion Heqbl. - subst. - exists (l :: nil); simpl; eauto. - - exploit IHHeqbl; eauto. - destruct 1 as (h & H3 & H4). - exists h. - split; auto. - erewrite find_label_is_end_block_not_label;eauto. - + (* Tr_add_label *) - intros. - exploit Mach_find_label_split; eauto. - clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. - inversion H0 as [H1]. - clear H0. - erewrite find_label_at_begin; simpl; eauto. - subst_is_trans_code Heqbl. - exists (l :: nil); simpl; eauto. - - subst; assert (H: l0 <> l); try congruence; clear H0. - exploit IHHeqbl; eauto. - clear IHHeqbl Heqbl. - intros (h & H3 & H4). - simpl; unfold is_label, add_label; simpl. - destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. - * destruct H5; try congruence. - exists (l0::h); simpl; intuition. - rewrite find_label_at_begin in H4; auto. - apply f_equal. inversion H4 as [H5]. clear H4. - destruct (trans_code c'); simpl in * |- *; - inversion H5; subst; simpl; auto. - * exists h. intuition. - erewrite <- find_label_add_label_diff; eauto. - + (* Tr_add_basic *) - intros. - exploit Mach_find_label_split; eauto. - destruct 1 as [(H2&H3)|(H2&H3)]. - rewrite H2 in H. unfold trans_inst in H. congruence. - exploit IHHeqbl; eauto. - clear IHHeqbl Heqbl. - intros (h & H4 & H5). - rewrite find_label_add_label_diff; auto. - rewrite find_label_add_label_diff in H5; eauto. - rewrite H0; auto. -Qed. - -Lemma find_label_preserved: - forall l f c, - Mach.find_label l (Mach.fn_code f) = Some c -> - exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). -Proof. - intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. - apply find_label_transcode_preserved; auto. -Qed. - -Lemma mem_free_preserved: - forall m stk f, - Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). -Proof. - intros. auto. -Qed. - -Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated - parent_sp_preserved. - - -Definition dist_end_block_code (c: Mach.code) := - match trans_code c with - | nil => 0 - | bh::_ => (size bh-1)%nat - end. - -Definition dist_end_block (s: Mach.state): nat := - match s with - | Mach.State _ _ _ c _ _ => dist_end_block_code c - | _ => 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. - -Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. -Proof. - unfold add_label, size; simpl; omega. -Qed. - -Lemma size_add_basic bi bh: header bh = nil -> size (add_basic bi bh) = size bh + 1. -Proof. - intro H. unfold add_basic, size; rewrite H; simpl. omega. -Qed. - - -Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. -Proof. - destruct i; auto. -Qed. - - -Lemma dist_end_block_code_simu_mid_block i c: - dist_end_block_code (i::c) <> 0 -> - (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). -Proof. - unfold dist_end_block_code. - remember (trans_code (i::c)) as bl. - rewrite <- is_trans_code_inv in Heqbl. - inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. - - rewrite size_add_to_newblock; omega. - - rewrite size_add_label; - subst_is_trans_code H. - omega. - - rewrite size_add_basic; auto. - subst_is_trans_code H. - omega. -Qed. - -Local Hint Resolve dist_end_block_code_simu_mid_block. - - -Lemma size_nonzero c b bl: - is_trans_code c (b :: bl) -> size b <> 0. -Proof. - intros H; inversion H; subst. - - rewrite size_add_to_newblock; omega. - - rewrite size_add_label; omega. - - rewrite size_add_basic; auto; omega. -Qed. - -Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := - | header_empty : is_header nil nil nil - | header_not_label i c: (forall l, i <> Mlabel l) -> is_header nil (i::c) (i::c) - | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 - . - -Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := - | body_empty : is_body nil nil nil - | body_not_bi i c: (forall bi, (trans_inst i) <> (MB_basic bi)) -> is_body nil (i::c) (i::c) - | body_is_bi i lbi c0 c1 bi: (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 - . - -Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := - | exit_empty: is_exit None nil nil - | exit_not_cfi i c: (forall cfi, (trans_inst i) <> MB_cfi cfi) -> is_exit None (i::c) (i::c) - | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c - . - -Lemma Mlabel_is_not_basic i: - forall bi, trans_inst i = MB_basic bi -> forall l, i <> Mlabel l. -Proof. -intros. -unfold trans_inst in H. -destruct i; congruence. -Qed. - -Lemma Mlabel_is_not_cfi i: - forall cfi, trans_inst i = MB_cfi cfi -> forall l, i <> Mlabel l. -Proof. -intros. -unfold trans_inst in H. -destruct i; congruence. -Qed. - -Lemma MBbasic_is_not_cfi i: - forall cfi, trans_inst i = MB_cfi cfi -> forall bi, trans_inst i <> MB_basic bi. -Proof. -intros. -unfold trans_inst in H. -unfold trans_inst. -destruct i; congruence. -Qed. - - -Local Hint Resolve Mlabel_is_not_cfi. -Local Hint Resolve MBbasic_is_not_cfi. - -Lemma add_to_new_block_is_label i: - header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. -Proof. - intros. - unfold add_to_new_bblock in H. - destruct (trans_inst i) eqn : H1. - + exists lbl. - unfold trans_inst in H1. - destruct i; congruence. - + unfold add_basic in H; simpl in H; congruence. - + unfold cfi_bblock in H; simpl in H; congruence. -Qed. - -Local Hint Resolve Mlabel_is_not_basic. - -Lemma trans_code_decompose c: forall b bl, - is_trans_code c (b::bl) -> - exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. -Proof. - induction c as [|i c]. - { (* nil => absurd *) intros b bl H; inversion H. } - intros b bl H; remember (trans_inst i) as ti. - destruct ti as [lbl|bi|cfi]; - inversion H as [|d0 d1 d2 H0 H1| |]; subst; - try (rewrite <- Heqti in * |- *); simpl in * |- *; - try congruence. - + (* label at end block *) - inversion H1; subst. inversion H0; subst. - assert (X:i=Mlabel lbl). { destruct i; simpl in Heqti; congruence. } - subst. repeat econstructor; eauto. - + (* label at mid block *) - exploit IHc; eauto. - intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). - repeat econstructor; eauto. - + (* basic at end block *) - inversion H1; subst. - lapply (Mlabel_is_not_basic i bi); auto. - intro H2. - - inversion H0; subst. - assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } - repeat econstructor; congruence. - - exists (i::c), c, c. - repeat econstructor; eauto; inversion H0; subst; repeat econstructor; simpl; try congruence. - * exploit (add_to_new_block_is_label i0); eauto. - intros (l & H8); subst; simpl; congruence. - * exploit H3; eauto. - * exploit (add_to_new_block_is_label i0); eauto. - intros (l & H8); subst; simpl; congruence. - + (* basic at mid block *) - inversion H1; subst. - exploit IHc; eauto. - intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). - exists (i::c0), c1, c2. - repeat econstructor; eauto. - rewrite H2 in H3. - inversion H3; econstructor; eauto. - + (* cfi at end block *) - inversion H1; subst; - repeat econstructor; eauto. -Qed. - - -Lemma step_simu_header st f sp rs m s c h c' t: - is_header h c c' -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> - s = Mach.State st f sp c' rs m /\ t = E0. -Proof. - induction 1; simpl; intros hs; try (inversion hs; tauto). - inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. -Qed. - - - -Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): - trans_inst i = MB_basic bi -> - Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> - exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. -Proof. - destruct i; simpl in * |-; - (discriminate - || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). - - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. - destruct H3 as (tf & A & B). subst. eapply A. - all: simpl; rewrite <- parent_sp_preserved; auto. - - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. - 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_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; - unfold Genv.symbol_address; rewrite symbols_preserved; auto. -Qed. - - -Lemma star_step_simu_body_step s f sp c bdy c': - is_body bdy c c' -> forall rs m t s', - starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> - exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. -Proof. - induction 1; simpl. - + intros. inversion H. exists rs. exists m. auto. - + intros. inversion H0. exists rs. exists m. auto. - + intros. inversion H1; subst. - exploit (step_simu_basic_step ); eauto. - destruct 1 as [ rs1 [ m1 Hs]]. - destruct Hs as [Hs1 [Hs2 Hs3]]. - destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. - destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. - exists rs2, m2. - 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. - - -Lemma match_states_concat_trans_code st f sp c rs m h: - match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). -Proof. - intros; constructor 1; simpl. - + intros (t0 & s1' & H0) t s'. - remember (trans_code _) as bl. - destruct bl as [|bh bl]. - { rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; inversion H0; congruence. } - clear H0. - simpl; constructor 1; - intros X; inversion X as [d1 d2 d3 d4 d5 d6 d7 rs' m' d10 d11 X1 X2| | | ]; subst; simpl in * |- *; - eapply exec_bblock; eauto; simpl; - inversion X2 as [cfi d1 d2 d3 H1|]; subst; eauto; - inversion H1; subst; eauto. - + intros H r; constructor 1; intro X; inversion X. -Qed. - -Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: - trans_inst i = MB_cfi cfi -> - is_trans_code c blc -> - Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> - exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s' s2. -Proof. - destruct i; simpl in * |-; - (intro H; intro Htc;apply is_trans_code_inv in Htc;rewrite Htc;inversion_clear H;intro X; inversion_clear X). - * eapply ex_intro. - intuition auto. - eapply exec_MBcall;eauto. - rewrite <-H; exploit (find_function_ptr_same); eauto. - * eapply ex_intro. - intuition auto. - eapply exec_MBtailcall;eauto. - - rewrite <-H; exploit (find_function_ptr_same); eauto. - - simpl; rewrite <- parent_sp_preserved; auto. - - simpl; rewrite <- parent_ra_preserved; auto. - * eapply ex_intro. - intuition auto. - eapply exec_MBbuiltin ;eauto. - * exploit find_label_transcode_preserved; eauto. - intros (x & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * exploit find_label_transcode_preserved; eauto. - intros (x & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBcond_false; eauto. - * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBreturn; eauto. - rewrite parent_sp_preserved in H0; subst; auto. - rewrite parent_ra_preserved in H1; subst; auto. -Qed. - -Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: - is_exit e c c' -> is_trans_code c' blc -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> - exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. -Proof. - destruct 1. - - (* None *) - intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). - split; eauto. - apply is_trans_code_inv in H0. - rewrite H0. - apply match_states_trans_state. - - (* None *) - intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). - split; eauto. - apply is_trans_code_inv in H0. - rewrite H0. - apply match_states_trans_state. - - (* Some *) - intros H0 H1. - inversion H1; subst. - exploit (step_simu_cfi_step); eauto. - intros [s2 [Hcfi1 Hcfi3]]. - inversion H4. subst; simpl. - autorewrite with trace_rewrite. - exists s2. - split;eauto. -Qed. - -Lemma simu_end_block: - forall s1 t s1', - starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> - exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. -Proof. - destruct s1; simpl. - + (* State *) - remember (trans_code _) as tc. - rewrite <- is_trans_code_inv in Heqtc. - intros t s1 H. - destruct tc as [|b bl]. - { (* nil => absurd *) - inversion Heqtc. subst. - unfold dist_end_block_code; simpl. - inversion_clear H; - inversion_clear H0. - } - assert (X: Datatypes.S (dist_end_block_code c) = (size b)). - { - unfold dist_end_block_code. - subst_is_trans_code Heqtc. - lapply (size_nonzero c b bl); auto. - omega. - } - rewrite X in H; unfold size in H. - (* decomposition of starN in 3 parts: header + body + exit *) - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as (t3&t4&s1'&H0&H3&H4). - subst t; clear X H. - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as (t1&t2&s1''&H&H1&H2). - subst t3; clear H0. - exploit trans_code_decompose; eauto. clear Heqtc. - intros (c0&c1&c2&Hc0&Hc1&Hc2&Heqtc). - (* header steps *) - exploit step_simu_header; eauto. - clear H; intros [X1 X2]; subst. - (* body steps *) - exploit (star_step_simu_body_step); eauto. - clear H1; intros (rs'&m'&H0&H1&H2). subst. - autorewrite with trace_rewrite. - (* exit step *) - exploit step_simu_exit_step; eauto. - clear H3; intros (s2' & H3 & H4). - eapply ex_intro; intuition eauto. - eapply exec_bblock; eauto. - + (* Callstate *) - intros t s1' H; inversion_clear H. - eapply ex_intro; constructor 1; eauto. - inversion H1; subst; clear H1. - inversion_clear H0; simpl. - - (* function_internal*) - cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. - eapply exec_function_internal; eauto. - rewrite <- parent_sp_preserved; eauto. - rewrite <- parent_ra_preserved; eauto. - - (* function_external *) - autorewrite with trace_rewrite. - eapply exec_function_external; eauto. - apply find_funct_ptr_same_external; auto. - rewrite <- parent_sp_preserved; eauto. - + (* Returnstate *) - intros t s1' H; inversion_clear H. - eapply ex_intro; constructor 1; eauto. - inversion H1; subst; clear H1. - inversion_clear H0; simpl. - eapply exec_return. -Qed. - - -Lemma cfi_dist_end_block i c: -(exists cfi, trans_inst i = MB_cfi cfi) -> -dist_end_block_code (i :: c) = 0. -Proof. - unfold dist_end_block_code. - intro H. destruct H as [cfi H]. - destruct i;simpl in H;try(congruence); ( - remember (trans_code _) as bl; - rewrite <- is_trans_code_inv in Heqbl; - inversion Heqbl; subst; simpl in * |- *; try (congruence)). -Qed. - -Theorem transf_program_correct: - forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). -Proof. - apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). -(* simu_mid_block *) - - intros s1 t s1' H1 H2. - destruct H1; simpl in * |- *; omega || (intuition auto); - destruct H2; eapply cfi_dist_end_block; simpl; eauto. -(* public_preserved *) - - apply senv_preserved. -(* match_initial_states *) - - intros. simpl. - eapply ex_intro; constructor 1. - eapply match_states_trans_state. - destruct H. split. - apply init_mem_preserved; auto. - rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. -(* match_final_states *) - - intros. simpl. destruct H. split with (r := r); auto. -(* final_states_end_block *) - - intros. simpl in H0. - inversion H0. - inversion H; simpl; auto. - all: try (subst; discriminate). - apply cfi_dist_end_block; exists MBreturn; eauto. -(* simu_end_block *) - - apply simu_end_block. -Qed. - -End PRESERVATION. - -(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) - - - -Lemma is_trans_code_monotonic i c b l: - is_trans_code c (b::l) -> - exists l' b', is_trans_code (i::c) (l' ++ (b'::l)). -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. } - 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. - 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. - rewrite <-Heqti. - eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. } - all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - - (*i=cfi*) - destruct i; try(simpl in Heqti; congruence). - all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; - cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; - rewrite Heqti; - eapply Tr_end_block; eauto; - rewrite <-Heqti; - eapply End_cfi; congruence. -Qed. - -Lemma trans_code_monotonic i c b l: - (b::l) = trans_code c -> - exists l' b', trans_code (i::c) = (l' ++ (b'::l)). -Proof. - intro H; rewrite <- is_trans_code_inv in H. - destruct (is_trans_code_monotonic i c b l H) as (l' & b' & H0). - subst_is_trans_code H0. - eauto. -Qed. - -(* FIXME: these two lemma should go into [Coqlib.v] *) -Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). -Proof. - induction l1; simpl; auto with coqlib. -Qed. -Hint Resolve is_tail_app: coqlib. - -Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. -Proof. - induction l1; simpl; auto with coqlib. - intros l2 l3 H; inversion H; eauto with coqlib. -Qed. -Hint Resolve is_tail_app_inv: coqlib. - - -Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> - exists b, is_tail (b :: trans_code c) (trans_code c2). -Proof. - intros H; induction 1. - - intros; subst. - remember (trans_code (Mcall _ _::c)) as tc2. - rewrite <- is_trans_code_inv in Heqtc2. - inversion Heqtc2; simpl in * |- *; subst; try congruence. - subst_is_trans_code H1. - eapply ex_intro; eauto with coqlib. - - intros; exploit IHis_tail; eauto. clear IHis_tail. - intros (b & Hb). inversion Hb; clear Hb. - * exploit (trans_code_monotonic i c2); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - exists b'; simpl; eauto with coqlib. - * exploit (trans_code_monotonic i c2); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - simpl; eapply ex_intro. - eapply is_tail_trans; eauto with coqlib. -Qed. - -Section Mach_Return_Address. - -Variable return_address_offset: function -> code -> ptrofs -> Prop. - -Hypothesis ra_exists: forall (b: bblock) (f: function) (c : list bblock), - is_tail (b :: c) (fn_code f) -> exists ra : ptrofs, return_address_offset f c ra. - -Definition Mach_return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - return_address_offset (transf_function f) (trans_code c) ofs. - -Lemma Mach_return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, Mach_return_address_offset f c ra. -Proof. - intros. - exploit Mach_Machblock_tail; eauto. - destruct 1. - eapply ra_exists; eauto. -Qed. - -End Mach_Return_Address. \ No newline at end of file diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v new file mode 100644 index 00000000..30393fd5 --- /dev/null +++ b/mppa_k1c/lib/Machblock.v @@ -0,0 +1,355 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. + +(** instructions "basiques" (ie non 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 + | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + . + +Definition bblock_body := list basic_inst. + +(** instructions de control flow *) +Inductive control_flow_inst: Type := + | MBcall: signature -> mreg + ident -> control_flow_inst + | MBtailcall: signature -> mreg + ident -> control_flow_inst + | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst + | MBgoto: label -> control_flow_inst + | MBcond: condition -> list mreg -> label -> control_flow_inst + | MBjumptable: mreg -> list label -> control_flow_inst + | MBreturn: control_flow_inst + . + +Record bblock := mk_bblock { + header: list label; + body: bblock_body; + exit: option control_flow_inst +}. + +Lemma bblock_eq: + forall b1 b2, + header b1 = header b2 -> + body b1 = body b2 -> + exit b1 = exit b2 -> + b1 = b2. +Proof. + intros. destruct b1. destruct b2. + simpl in *. subst. auto. +Qed. + +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). + +Lemma size_null b: + size b = 0%nat -> + header b = nil /\ body b = nil /\ exit b = None. +Proof. + destruct b as [h b e]. simpl. unfold size. simpl. + intros H. + assert (length h = 0%nat) as Hh; [ omega |]. + assert (length b = 0%nat) as Hb; [ omega |]. + assert (length_opt e = 0%nat) as He; [ omega|]. + repeat split. + destruct h; try (simpl in Hh; discriminate); auto. + destruct b; try (simpl in Hb; discriminate); auto. + destruct e; try (simpl in He; discriminate); auto. +Qed. + +Definition code := list bblock. + +Record function: Type := mkfunction + { fn_sig: signature; + fn_code: code; + fn_stacksize: Z; + fn_link_ofs: ptrofs; + fn_retaddr_ofs: ptrofs }. + +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef unit. + +Definition genv := Genv.t fundef unit. + +(*** sémantique ***) + +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + +Local Open Scope nat_scope. + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Section RELSEM. + +Variable rao:function -> code -> ptrofs -> Prop. +Variable ge:genv. + +Definition find_function_ptr + (ge: genv) (ros: mreg + ident) (rs: regset) : option block := + match ros with + | inl r => + match rs r with + | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None + | _ => None + end + | inr symb => + Genv.find_symbol ge symb + end. + +(** Machblock execution states. *) + +Inductive stackframe: Type := + | Stackframe: + forall (f: block) (**r pointer to calling function *) + (sp: val) (**r stack pointer in calling function *) + (retaddr: val) (**r Asm return address in calling function *) + (c: code), (**r program point in calling function *) + stackframe. + +Inductive state: Type := + | State: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to current function *) + (sp: val) (**r stack pointer *) + (c: code) (**r current program point *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Callstate: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to function to call *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Returnstate: + forall (stack: list stackframe) (**r call stack *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state. + +Definition parent_sp (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => sp + end. + +Definition parent_ra (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => ra + end. + +Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := + | exec_MBgetstack: + forall ofs ty dst v, + load_stack m sp ty ofs = Some v -> + basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m + | exec_MBsetstack: + forall src ofs ty m' rs', + store_stack m sp ty ofs (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_setstack ty) rs -> + basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' + | exec_MBgetparam: + forall ofs ty dst v rs' f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> + rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> + basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m + | exec_MBop: + forall op args v rs' res, + eval_operation ge sp op rs##args m = Some v -> + 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, + 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 + | exec_MBstore: + forall chunk addr args src m' a rs', + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_store chunk addr) rs -> + basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' + . + + +Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := + | exec_nil_body: + forall rs m, + body_step s f sp nil rs m rs m + | exec_cons_body: + forall rs m bi p rs' m' rs'' m'', + basic_step s f sp rs m bi rs' m' -> + body_step s f sp p rs' m' rs'' m'' -> + body_step s f sp (bi::p) rs m rs'' m'' + . + +Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := + | exec_MBcall: + forall s fb sp sig ros c b rs m f f' ra, + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + rao f c ra -> + cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) + E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) + f' rs m) + | exec_MBtailcall: + forall s fb stk soff sig ros c rs m f f' m', + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) + E0 (Callstate s f' rs m') + | exec_MBbuiltin: + forall s f sp rs m ef args res b c vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> + cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) + t (State s f sp c rs' m') + | exec_MBgoto: + forall s fb f sp lbl c rs m c', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + cfi_step (MBgoto lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs m) + | exec_MBcond_true: + forall s fb f sp cond args lbl c rs m c' rs', + eval_condition cond rs##args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBcond_false: + forall s f sp cond args lbl b c rs m rs', + eval_condition cond rs##args m = Some false -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) + E0 (State s f sp c rs' m) + | exec_MBjumptable: + forall s fb f sp arg tbl c rs m n lbl c' rs', + rs arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs destroyed_by_jumptable rs -> + cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBreturn: + forall s fb stk soff c rs m f m', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) + E0 (Returnstate s rs m') + . + +Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := + | exec_Some_exit: + forall ctl s t s', + cfi_step ctl s t s' -> + exit_step (Some ctl) s t s' + | exec_None_exit: + forall stk f sp b lb rs m, + exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) + . + +Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall sf f sp bb c rs m rs' m' t s', + body_step sf f sp (body bb) rs m rs' m' -> + exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> + step (State sf f sp (bb::c) rs m) t s' + | exec_function_internal: + forall s fb rs m f m1 m2 m3 stk rs', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + let sp := Vptr stk Ptrofs.zero in + store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + rs' = undef_regs destroyed_at_function_entry rs -> + step (Callstate s fb rs m) + E0 (State s fb sp f.(fn_code) rs' m3) + | exec_function_external: + forall s fb rs m t rs' ef args res m', + Genv.find_funct_ptr ge fb = Some (External ef) -> + extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> + external_call ef ge args m t res m' -> + rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> + step (Callstate s fb rs m) + t (Returnstate s rs' m') + | exec_return: + forall s f sp ra c rs m, + step (Returnstate (Stackframe f sp ra c :: s) rs m) + E0 (State s f sp c rs m) + . + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall fb m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some fb -> + initial_state p (Callstate nil fb (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r retcode, + loc_result signature_main = One r -> + rs r = Vint retcode -> + final_state (Returnstate nil rs m) retcode. + +Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := + Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v new file mode 100644 index 00000000..4dfc309e --- /dev/null +++ b/mppa_k1c/lib/Machblockgen.v @@ -0,0 +1,207 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. + +Inductive Machblock_inst: Type := +| MB_label (lbl: label) +| MB_basic (bi: basic_inst) +| MB_cfi (cfi: control_flow_inst). + +Definition trans_inst (i:Mach.instruction) : Machblock_inst := + match i with + | Mcall sig ros => MB_cfi (MBcall sig ros) + | Mtailcall sig ros => MB_cfi (MBtailcall sig ros) + | Mbuiltin ef args res => MB_cfi (MBbuiltin ef args res) + | Mgoto lbl => MB_cfi (MBgoto lbl) + | Mcond cond args lbl => MB_cfi (MBcond cond args lbl) + | Mjumptable arg tbl => MB_cfi (MBjumptable arg tbl) + | Mreturn => MB_cfi (MBreturn) + | Mgetstack ofs ty dst => MB_basic (MBgetstack ofs ty dst) + | 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) + | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) + | Mlabel l => MB_label l + end. + +Definition empty_bblock:={| header := nil; body := nil; exit := None |}. +Extraction Inline empty_bblock. + +Definition add_label l bb:={| header := l::(header bb); body := (body bb); exit := (exit bb) |}. +Extraction Inline add_label. + +Definition add_basic bi bb :={| header := nil; body := bi::(body bb); exit := (exit bb) |}. +Extraction Inline add_basic. + +Definition cfi_bblock cfi:={| header := nil; body := nil; exit := Some cfi |}. +Extraction Inline cfi_bblock. + +Definition add_to_new_bblock (i:Machblock_inst) : bblock := + match i with + | MB_label l => add_label l empty_bblock + | MB_basic i => add_basic i empty_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)*) +Definition add_to_code (i:Machblock_inst) (bl:code) : code := + match bl with + | bh::bl0 => match i with + | MB_label l => add_label l bh::bl0 + | MB_cfi i0 => cfi_bblock i0::bl + | MB_basic i0 => match header bh with + |_::_ => add_basic i0 empty_bblock::bl + | nil => add_basic i0 bh::bl0 + end + end + | _ => add_to_new_bblock i::nil + end. + +Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := + match c with + | nil => bl + | i::c0 => + trans_code_rev c0 (add_to_code (trans_inst i) bl) + end. + +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); + fn_stacksize := Mach.fn_stacksize f; + fn_link_ofs := Mach.fn_link_ofs f; + fn_retaddr_ofs := Mach.fn_retaddr_ofs f + |}. + +Definition transf_fundef (f: Mach.fundef) : fundef := + transf_fundef transf_function f. + +Definition transf_program (src: Mach.program) : program := + transform_program transf_fundef src. + + +(** Abstraction de 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. + +Inductive is_trans_code: Mach.code -> code -> Prop := + | Tr_nil: is_trans_code nil nil + | Tr_end_block i c bl: + is_trans_code c bl -> + is_end_block (trans_inst i) bl -> + is_trans_code (i::c) (add_to_new_bblock (trans_inst i)::bl) + | Tr_add_label i l bh c bl: + is_trans_code c (bh::bl) -> + i = Mlabel l -> + is_trans_code (i::c) (add_label l bh::bl) + | Tr_add_basic i bi bh c bl: + is_trans_code c (bh::bl) -> + trans_inst i = MB_basic bi -> + header bh = nil -> + is_trans_code (i::c) (add_basic bi bh::bl). + +Local Hint Resolve Tr_nil Tr_end_block. + +Lemma add_to_code_is_trans_code i c bl: + is_trans_code c bl -> + is_trans_code (i::c) (add_to_code (trans_inst i) bl). +Proof. + destruct bl as [|bh0 bl]; simpl. + - intro H. inversion H. subst. eauto. + - remember (trans_inst i) as ti. + destruct ti as [l|bi|cfi]. + + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. + + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. + * eapply Tr_add_basic; eauto. + * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. + rewrite Heqti; eapply Tr_end_block; eauto. + rewrite <- Heqti. eapply End_basic. congruence. + + intros. + cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. + rewrite Heqti. eapply Tr_end_block; eauto. + rewrite <- Heqti. eapply End_cfi. congruence. +Qed. + +Local Hint Resolve add_to_code_is_trans_code. + +Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, + is_trans_code c2 mbi -> + is_trans_code (rev_append c1 c2) (trans_code_rev c1 mbi). +Proof. + induction c1 as [| i c1]; simpl; auto. +Qed. + +Lemma trans_code_is_trans_code c: is_trans_code c (trans_code c). +Proof. + unfold trans_code. + rewrite <- rev_alt. + rewrite <- (rev_involutive c) at 1. + rewrite rev_alt at 1. + apply trans_code_is_trans_code_rev; auto. +Qed. + +Lemma add_to_code_is_trans_code_inv i c bl: + is_trans_code (i::c) bl -> exists bl0, is_trans_code c bl0 /\ bl = add_to_code (trans_inst i) bl0. +Proof. + intro H; inversion H as [|H0 H1 bl0| | H0 bi bh H1 bl0]; clear H; subst; (repeat econstructor); eauto. + + (* case Tr_end_block *) inversion H3; subst; simpl; auto. + * destruct (header bh); congruence. + * destruct bl0; simpl; congruence. + + (* case Tr_add_basic *) rewrite H3. simpl. destruct (header bh); congruence. +Qed. + +Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, + is_trans_code (rev_append c1 c2) mbi -> + exists mbi0, is_trans_code c2 mbi0 /\ mbi=trans_code_rev c1 mbi0. +Proof. + induction c1 as [| i c1]; simpl; eauto. + intros; exploit IHc1; eauto. + intros (mbi0 & H1 & H2); subst. + exploit add_to_code_is_trans_code_inv; eauto. + intros. destruct H0 as [mbi1 [H2 H3]]. + exists mbi1. split; congruence. +Qed. + +Local Hint Resolve trans_code_is_trans_code. + +Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). +Proof. + constructor; intros; subst; auto. + unfold trans_code. + exploit (trans_code_is_trans_code_rev_inv (rev_append c nil) nil bl); eauto. + * rewrite <- rev_alt. + rewrite <- rev_alt. + rewrite (rev_involutive c). + apply H. + * intros. + destruct H0 as [mbi [H0 H1]]. + inversion H0. subst. reflexivity. +Qed. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v new file mode 100644 index 00000000..9186e54a --- /dev/null +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -0,0 +1,806 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. +Require Import Machblockgen. +Require Import ForwardSimulationBlock. + +Ltac subst_is_trans_code H := + rewrite is_trans_code_inv in H; + rewrite <- H in * |- *; + rewrite <- is_trans_code_inv in H. + +Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := + rao (transf_function f) (trans_code c). + +Definition match_prog (p: Mach.program) (tp: Machblock.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. + +Definition trans_stackframe (msf: Mach.stackframe) : stackframe := + match msf with + | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) + end. + +Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := + match mst with + | nil => nil + | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) + end. + +Definition trans_state (ms: Mach.state): state := + match ms with + | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m + | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m + | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m + end. + +Section PRESERVATION. + +Local Open Scope nat_scope. + +Variable prog: Mach.program. +Variable tprog: Machblock.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + + +Variable rao: function -> code -> ptrofs -> Prop. + +Definition match_states: Mach.state -> state -> Prop + := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + apply match_states_trans_state. +Qed. + +Local Hint Resolve match_states_trans_state. + +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 init_mem_preserved: + forall m, + Genv.init_mem prog = Some m -> + Genv.init_mem tprog = Some m. +Proof (Genv.init_mem_transf TRANSF). + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main 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 = tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. + destruct H0 as (cunit & tf & A & B & C). + eapply ex_intro. intuition; eauto. subst. eapply A. +Qed. + +Lemma find_function_ptr_same: + forall s rs, + Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. +Proof. + intros. unfold Mach.find_function_ptr. unfold find_function_ptr. + destruct s; auto. + rewrite symbols_preserved; auto. +Qed. + +Lemma find_funct_ptr_same: + forall f f0, + Genv.find_funct_ptr ge f = Some (Internal f0) -> + Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma find_funct_ptr_same_external: + forall f f0, + Genv.find_funct_ptr ge f = Some (External f0) -> + Genv.find_funct_ptr tge f = Some (External f0). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma parent_sp_preserved: + forall s, + Mach.parent_sp s = parent_sp (trans_stack s). +Proof. + unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma parent_ra_preserved: + forall s, + Mach.parent_ra s = parent_ra (trans_stack s). +Proof. + unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma external_call_preserved: + forall ef args m t res m', + external_call ef ge args m t res m' -> + external_call ef tge args m t res m'. +Proof. + intros. eapply external_call_symbols_preserved; eauto. + apply senv_preserved. +Qed. + +Lemma Mach_find_label_split l i c c': + Mach.find_label l (i :: c) = Some c' -> + (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). +Proof. + intros H. + destruct i; try (constructor 2; split; auto; discriminate ). + destruct (peq l0 l) as [P|P]. + - constructor. subst l0; split; auto. + revert H. unfold Mach.find_label. simpl. rewrite peq_true. + intros H; injection H; auto. + - constructor 2. split. + + intro F. injection F. intros. contradict P; auto. + + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. +Qed. + +Lemma find_label_is_end_block_not_label i l c bl: + is_end_block (trans_inst i) bl -> + is_trans_code c bl -> + i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. +Proof. + intros H H0 H1. + unfold find_label. + remember (is_label l _) as b. + cutrewrite (b = false); auto. + subst; unfold is_label. + destruct i; simpl in * |- *; try (destruct (in_dec l nil); intuition). + inversion H. + destruct (in_dec l (l0::nil)) as [H6|H6]; auto. + simpl in H6; intuition try congruence. +Qed. + +Lemma find_label_at_begin l bh bl: + In l (header bh) + -> find_label l (bh :: bl) = Some (bh::bl). +Proof. + unfold find_label; rewrite is_label_correct_true; intro H; rewrite H; simpl; auto. +Qed. + +Lemma find_label_add_label_diff l bh bl: + ~(In l (header bh)) -> + find_label l (bh::bl) = find_label l bl. +Proof. + unfold find_label; rewrite is_label_correct_false; intro H; rewrite H; simpl; auto. +Qed. + +Definition concat (h: list label) (c: code): code := + match c with + | nil => {| header := h; body := nil; exit := None |}::nil + | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' + end. + +Lemma find_label_transcode_preserved: + forall l c c', + Mach.find_label l c = Some c' -> + exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). +Proof. + intros l c. remember (trans_code _) as bl. + rewrite <- is_trans_code_inv in * |-. + induction Heqbl. + + (* Tr_nil *) + intros; exists (l::nil); simpl in * |- *; intuition. + discriminate. + + (* Tr_end_block *) + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. rewrite find_label_at_begin; simpl; auto. + inversion H as [mbi H1 H2| | ]. + subst. + inversion Heqbl. + subst. + exists (l :: nil); simpl; eauto. + - exploit IHHeqbl; eauto. + destruct 1 as (h & H3 & H4). + exists h. + split; auto. + erewrite find_label_is_end_block_not_label;eauto. + + (* Tr_add_label *) + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. + inversion H0 as [H1]. + clear H0. + erewrite find_label_at_begin; simpl; eauto. + subst_is_trans_code Heqbl. + exists (l :: nil); simpl; eauto. + - subst; assert (H: l0 <> l); try congruence; clear H0. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. + intros (h & H3 & H4). + simpl; unfold is_label, add_label; simpl. + destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. + * destruct H5; try congruence. + exists (l0::h); simpl; intuition. + rewrite find_label_at_begin in H4; auto. + apply f_equal. inversion H4 as [H5]. clear H4. + destruct (trans_code c'); simpl in * |- *; + inversion H5; subst; simpl; auto. + * exists h. intuition. + erewrite <- find_label_add_label_diff; eauto. + + (* Tr_add_basic *) + intros. + exploit Mach_find_label_split; eauto. + destruct 1 as [(H2&H3)|(H2&H3)]. + rewrite H2 in H. unfold trans_inst in H. congruence. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. + intros (h & H4 & H5). + rewrite find_label_add_label_diff; auto. + rewrite find_label_add_label_diff in H5; eauto. + rewrite H0; auto. +Qed. + +Lemma find_label_preserved: + forall l f c, + Mach.find_label l (Mach.fn_code f) = Some c -> + exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). +Proof. + intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. + apply find_label_transcode_preserved; auto. +Qed. + +Lemma mem_free_preserved: + forall m stk f, + Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). +Proof. + intros. auto. +Qed. + +Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated + parent_sp_preserved. + + +Definition dist_end_block_code (c: Mach.code) := + match trans_code c with + | nil => 0 + | bh::_ => (size bh-1)%nat + end. + +Definition dist_end_block (s: Mach.state): nat := + match s with + | Mach.State _ _ _ c _ _ => dist_end_block_code c + | _ => 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. + +Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. +Proof. + unfold add_label, size; simpl; omega. +Qed. + +Lemma size_add_basic bi bh: header bh = nil -> size (add_basic bi bh) = size bh + 1. +Proof. + intro H. unfold add_basic, size; rewrite H; simpl. omega. +Qed. + + +Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. +Proof. + destruct i; auto. +Qed. + + +Lemma dist_end_block_code_simu_mid_block i c: + dist_end_block_code (i::c) <> 0 -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). +Proof. + unfold dist_end_block_code. + remember (trans_code (i::c)) as bl. + rewrite <- is_trans_code_inv in Heqbl. + inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; + subst_is_trans_code H. + omega. + - rewrite size_add_basic; auto. + subst_is_trans_code H. + omega. +Qed. + +Local Hint Resolve dist_end_block_code_simu_mid_block. + + +Lemma size_nonzero c b bl: + is_trans_code c (b :: bl) -> size b <> 0. +Proof. + intros H; inversion H; subst. + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; omega. + - rewrite size_add_basic; auto; omega. +Qed. + +Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := + | header_empty : is_header nil nil nil + | header_not_label i c: (forall l, i <> Mlabel l) -> is_header nil (i::c) (i::c) + | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 + . + +Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := + | body_empty : is_body nil nil nil + | body_not_bi i c: (forall bi, (trans_inst i) <> (MB_basic bi)) -> is_body nil (i::c) (i::c) + | body_is_bi i lbi c0 c1 bi: (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 + . + +Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := + | exit_empty: is_exit None nil nil + | exit_not_cfi i c: (forall cfi, (trans_inst i) <> MB_cfi cfi) -> is_exit None (i::c) (i::c) + | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c + . + +Lemma Mlabel_is_not_basic i: + forall bi, trans_inst i = MB_basic bi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma Mlabel_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma MBbasic_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall bi, trans_inst i <> MB_basic bi. +Proof. +intros. +unfold trans_inst in H. +unfold trans_inst. +destruct i; congruence. +Qed. + + +Local Hint Resolve Mlabel_is_not_cfi. +Local Hint Resolve MBbasic_is_not_cfi. + +Lemma add_to_new_block_is_label i: + header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. +Proof. + intros. + unfold add_to_new_bblock in H. + destruct (trans_inst i) eqn : H1. + + exists lbl. + unfold trans_inst in H1. + destruct i; congruence. + + unfold add_basic in H; simpl in H; congruence. + + unfold cfi_bblock in H; simpl in H; congruence. +Qed. + +Local Hint Resolve Mlabel_is_not_basic. + +Lemma trans_code_decompose c: forall b bl, + is_trans_code c (b::bl) -> + exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. +Proof. + induction c as [|i c]. + { (* nil => absurd *) intros b bl H; inversion H. } + intros b bl H; remember (trans_inst i) as ti. + destruct ti as [lbl|bi|cfi]; + inversion H as [|d0 d1 d2 H0 H1| |]; subst; + try (rewrite <- Heqti in * |- *); simpl in * |- *; + try congruence. + + (* label at end block *) + inversion H1; subst. inversion H0; subst. + assert (X:i=Mlabel lbl). { destruct i; simpl in Heqti; congruence. } + subst. repeat econstructor; eauto. + + (* label at mid block *) + exploit IHc; eauto. + intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). + repeat econstructor; eauto. + + (* basic at end block *) + inversion H1; subst. + lapply (Mlabel_is_not_basic i bi); auto. + intro H2. + - inversion H0; subst. + assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } + repeat econstructor; congruence. + - exists (i::c), c, c. + repeat econstructor; eauto; inversion H0; subst; repeat econstructor; simpl; try congruence. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + * exploit H3; eauto. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + + (* basic at mid block *) + inversion H1; subst. + exploit IHc; eauto. + intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). + exists (i::c0), c1, c2. + repeat econstructor; eauto. + rewrite H2 in H3. + inversion H3; econstructor; eauto. + + (* cfi at end block *) + inversion H1; subst; + repeat econstructor; eauto. +Qed. + + +Lemma step_simu_header st f sp rs m s c h c' t: + is_header h c c' -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> + s = Mach.State st f sp c' rs m /\ t = E0. +Proof. + induction 1; simpl; intros hs; try (inversion hs; tauto). + inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. +Qed. + + + +Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): + trans_inst i = MB_basic bi -> + Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. +Proof. + destruct i; simpl in * |-; + (discriminate + || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). + - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. + destruct H3 as (tf & A & B). subst. eapply A. + all: simpl; rewrite <- parent_sp_preserved; auto. + - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. + 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_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. +Qed. + + +Lemma star_step_simu_body_step s f sp c bdy c': + is_body bdy c c' -> forall rs m t s', + starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. +Proof. + induction 1; simpl. + + intros. inversion H. exists rs. exists m. auto. + + intros. inversion H0. exists rs. exists m. auto. + + intros. inversion H1; subst. + exploit (step_simu_basic_step ); eauto. + destruct 1 as [ rs1 [ m1 Hs]]. + destruct Hs as [Hs1 [Hs2 Hs3]]. + destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. + destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. + exists rs2, m2. + 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. + + +Lemma match_states_concat_trans_code st f sp c rs m h: + match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). +Proof. + intros; constructor 1; simpl. + + intros (t0 & s1' & H0) t s'. + remember (trans_code _) as bl. + destruct bl as [|bh bl]. + { rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; inversion H0; congruence. } + clear H0. + simpl; constructor 1; + intros X; inversion X as [d1 d2 d3 d4 d5 d6 d7 rs' m' d10 d11 X1 X2| | | ]; subst; simpl in * |- *; + eapply exec_bblock; eauto; simpl; + inversion X2 as [cfi d1 d2 d3 H1|]; subst; eauto; + inversion H1; subst; eauto. + + intros H r; constructor 1; intro X; inversion X. +Qed. + +Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: + trans_inst i = MB_cfi cfi -> + is_trans_code c blc -> + Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> + exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s' s2. +Proof. + destruct i; simpl in * |-; + (intro H; intro Htc;apply is_trans_code_inv in Htc;rewrite Htc;inversion_clear H;intro X; inversion_clear X). + * eapply ex_intro. + intuition auto. + eapply exec_MBcall;eauto. + rewrite <-H; exploit (find_function_ptr_same); eauto. + * eapply ex_intro. + intuition auto. + eapply exec_MBtailcall;eauto. + - rewrite <-H; exploit (find_function_ptr_same); eauto. + - simpl; rewrite <- parent_sp_preserved; auto. + - simpl; rewrite <- parent_ra_preserved; auto. + * eapply ex_intro. + intuition auto. + eapply exec_MBbuiltin ;eauto. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBcond_false; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBreturn; eauto. + rewrite parent_sp_preserved in H0; subst; auto. + rewrite parent_ra_preserved in H1; subst; auto. +Qed. + +Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: + is_exit e c c' -> is_trans_code c' blc -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> + exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. +Proof. + destruct 1. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* Some *) + intros H0 H1. + inversion H1; subst. + exploit (step_simu_cfi_step); eauto. + intros [s2 [Hcfi1 Hcfi3]]. + inversion H4. subst; simpl. + autorewrite with trace_rewrite. + exists s2. + split;eauto. +Qed. + +Lemma simu_end_block: + forall s1 t s1', + starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> + exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. +Proof. + destruct s1; simpl. + + (* State *) + remember (trans_code _) as tc. + rewrite <- is_trans_code_inv in Heqtc. + intros t s1 H. + destruct tc as [|b bl]. + { (* nil => absurd *) + inversion Heqtc. subst. + unfold dist_end_block_code; simpl. + inversion_clear H; + inversion_clear H0. + } + assert (X: Datatypes.S (dist_end_block_code c) = (size b)). + { + unfold dist_end_block_code. + subst_is_trans_code Heqtc. + lapply (size_nonzero c b bl); auto. + omega. + } + rewrite X in H; unfold size in H. + (* decomposition of starN in 3 parts: header + body + exit *) + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as (t3&t4&s1'&H0&H3&H4). + subst t; clear X H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as (t1&t2&s1''&H&H1&H2). + subst t3; clear H0. + exploit trans_code_decompose; eauto. clear Heqtc. + intros (c0&c1&c2&Hc0&Hc1&Hc2&Heqtc). + (* header steps *) + exploit step_simu_header; eauto. + clear H; intros [X1 X2]; subst. + (* body steps *) + exploit (star_step_simu_body_step); eauto. + clear H1; intros (rs'&m'&H0&H1&H2). subst. + autorewrite with trace_rewrite. + (* exit step *) + exploit step_simu_exit_step; eauto. + clear H3; intros (s2' & H3 & H4). + eapply ex_intro; intuition eauto. + eapply exec_bblock; eauto. + + (* Callstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + - (* function_internal*) + cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. + eapply exec_function_internal; eauto. + rewrite <- parent_sp_preserved; eauto. + rewrite <- parent_ra_preserved; eauto. + - (* function_external *) + autorewrite with trace_rewrite. + eapply exec_function_external; eauto. + apply find_funct_ptr_same_external; auto. + rewrite <- parent_sp_preserved; eauto. + + (* Returnstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + eapply exec_return. +Qed. + + +Lemma cfi_dist_end_block i c: +(exists cfi, trans_inst i = MB_cfi cfi) -> +dist_end_block_code (i :: c) = 0. +Proof. + unfold dist_end_block_code. + intro H. destruct H as [cfi H]. + destruct i;simpl in H;try(congruence); ( + remember (trans_code _) as bl; + rewrite <- is_trans_code_inv in Heqbl; + inversion Heqbl; subst; simpl in * |- *; try (congruence)). +Qed. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). +Proof. + apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). +(* simu_mid_block *) + - intros s1 t s1' H1 H2. + destruct H1; simpl in * |- *; omega || (intuition auto); + destruct H2; eapply cfi_dist_end_block; simpl; eauto. +(* public_preserved *) + - apply senv_preserved. +(* match_initial_states *) + - intros. simpl. + eapply ex_intro; constructor 1. + eapply match_states_trans_state. + destruct H. split. + apply init_mem_preserved; auto. + rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. +(* match_final_states *) + - intros. simpl. destruct H. split with (r := r); auto. +(* final_states_end_block *) + - intros. simpl in H0. + inversion H0. + inversion H; simpl; auto. + all: try (subst; discriminate). + apply cfi_dist_end_block; exists MBreturn; eauto. +(* simu_end_block *) + - apply simu_end_block. +Qed. + +End PRESERVATION. + +(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) + + + +Lemma is_trans_code_monotonic i c b l: + is_trans_code c (b::l) -> + exists l' b', is_trans_code (i::c) (l' ++ (b'::l)). +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. } + 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. + 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. + rewrite <-Heqti. + eapply End_basic. inversion H; try(simpl; congruence). + simpl in H5; congruence. } + all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). + - (*i=cfi*) + destruct i; try(simpl in Heqti; congruence). + all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; + cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; + rewrite Heqti; + eapply Tr_end_block; eauto; + rewrite <-Heqti; + eapply End_cfi; congruence. +Qed. + +Lemma trans_code_monotonic i c b l: + (b::l) = trans_code c -> + exists l' b', trans_code (i::c) = (l' ++ (b'::l)). +Proof. + intro H; rewrite <- is_trans_code_inv in H. + destruct (is_trans_code_monotonic i c b l H) as (l' & b' & H0). + subst_is_trans_code H0. + eauto. +Qed. + +(* FIXME: these two lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + +Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> + exists b, is_tail (b :: trans_code c) (trans_code c2). +Proof. + intros H; induction 1. + - intros; subst. + remember (trans_code (Mcall _ _::c)) as tc2. + rewrite <- is_trans_code_inv in Heqtc2. + inversion Heqtc2; simpl in * |- *; subst; try congruence. + subst_is_trans_code H1. + eapply ex_intro; eauto with coqlib. + - intros; exploit IHis_tail; eauto. clear IHis_tail. + intros (b & Hb). inversion Hb; clear Hb. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + exists b'; simpl; eauto with coqlib. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eapply ex_intro. + eapply is_tail_trans; eauto with coqlib. +Qed. + +Section Mach_Return_Address. + +Variable return_address_offset: function -> code -> ptrofs -> Prop. + +Hypothesis ra_exists: forall (b: bblock) (f: function) (c : list bblock), + is_tail (b :: c) (fn_code f) -> exists ra : ptrofs, return_address_offset f c ra. + +Definition Mach_return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := + return_address_offset (transf_function f) (trans_code c) ofs. + +Lemma Mach_return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, Mach_return_address_offset f c ra. +Proof. + intros. + exploit Mach_Machblock_tail; eauto. + destruct 1. + eapply ra_exists; eauto. +Qed. + +End Mach_Return_Address. \ No newline at end of file -- cgit From 11aa243fe776dc99001004a74b8ed0fc42c12fc9 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 21 May 2019 16:31:02 +0200 Subject: move Asmblockgenproof0 from lib to mppa_k1c/ This file is specific to our backend. --- mppa_k1c/Asmblockgenproof0.v | 1134 ++++++++++++++++++++++++++++++++++++++ mppa_k1c/lib/Asmblockgenproof0.v | 1134 -------------------------------------- 2 files changed, 1134 insertions(+), 1134 deletions(-) create mode 100644 mppa_k1c/Asmblockgenproof0.v delete mode 100644 mppa_k1c/lib/Asmblockgenproof0.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v new file mode 100644 index 00000000..89d41017 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof0.v @@ -0,0 +1,1134 @@ +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +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] *) + +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. + +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. + +(* 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. + + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +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') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree 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 Mach.undef_regs_other; 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_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 -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +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). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.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). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +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) -> + 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. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +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], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + 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 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +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 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + 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. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. rewrite regset_same_assign. auto. + 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. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v deleted file mode 100644 index 89d41017..00000000 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ /dev/null @@ -1,1134 +0,0 @@ -Require Import Coqlib. -Require Intv. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -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] *) - -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. - -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. - -(* 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. - - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -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') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree 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 Mach.undef_regs_other; 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_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 -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -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). -Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.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). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -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) -> - 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. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -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], - and [tc] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -Proof. - intros. destruct H. auto. -Qed. - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - 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 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -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 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - 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. - apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. -Qed. - -Lemma exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. rewrite regset_same_assign. auto. - 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. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. -- cgit From fd7a801bef1e9fe6e47b62c5c1b0905a4dde7ae8 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 26 May 2019 08:50:44 +0200 Subject: extending bblock_simu_test with rewriting --- mppa_k1c/Asmblockdeps.v | 63 +- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 130 ++- mppa_k1c/abstractbb/DepTreeTheory.v | 456 -------- mppa_k1c/abstractbb/ImpDep.v | 960 ----------------- mppa_k1c/abstractbb/ImpSimuTest.v | 1108 ++++++++++++++++++++ mppa_k1c/abstractbb/Impure/ImpCore.v | 2 +- mppa_k1c/abstractbb/Impure/ImpHCons.v | 104 +- mppa_k1c/abstractbb/Impure/ImpLoops.v | 8 +- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 51 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 37 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 5 +- mppa_k1c/abstractbb/Parallelizability.v | 4 +- mppa_k1c/abstractbb/SeqSimuTheory.v | 428 ++++++++ 13 files changed, 1825 insertions(+), 1531 deletions(-) delete mode 100644 mppa_k1c/abstractbb/DepTreeTheory.v delete mode 100644 mppa_k1c/abstractbb/ImpDep.v create mode 100644 mppa_k1c/abstractbb/ImpSimuTest.v create mode 100644 mppa_k1c/abstractbb/SeqSimuTheory.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index eb3900d5..e0aaee58 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -9,7 +9,7 @@ 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. @@ -302,30 +302,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 => @@ -507,7 +483,7 @@ Include MkSeqLanguage P. End L. -Module IDT := ImpDepTree L ImpPosDict. +Module IST := ImpSimu L ImpPosDict. Import L. Import P. @@ -1593,16 +1569,35 @@ 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. + +Program Definition failsafe_reduce := Terms.failsafe_reduce is_constant. +Obligation 1. + 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 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 failsafe_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 failsafe_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, Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. wlp_simplify. Qed. @@ -1614,7 +1609,7 @@ Import UnsafeImpure. Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). -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 -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. @@ -1622,9 +1617,7 @@ 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 -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). -Qed. - -End SECT_BBLOCK_EQUIV. +Qed. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 618f3ebe..f381c810 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,6 +1,6 @@ (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) - +Require Import ImpPrelude. Module Type PseudoRegisters. @@ -24,16 +24,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 +46,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 +135,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 +235,121 @@ 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. + + +Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. + +Record pseudo_term: Type := { + valid: list term; + effect: term +}. + +Definition match_pseudo_term (t: term) (pt: pseudo_term) := + (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(valid) m) + /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). + +Import ImpCore.Notations. +Local Open Scope impure_scope. + +Record reduction (t:term):= { + result:> ?? pseudo_term; + result_correct: WHEN result ~> pt THEN match_pseudo_term t pt; +}. +Hint Resolve result_correct: wlp. + +Program Definition identity_reduce (t: term): reduction t := {| result := RET {| valid := [t]; effect := t |} |}. +Obligation 1. + unfold match_pseudo_term, allvalid; wlp_simplify; congruence. +Qed. +Global Opaque identity_reduce. + +Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := + match t with + | Input x _ => {| result := RET {| valid := []; effect := t |} |} + | o @ [] => match is_constant o with + | true => {| result := RET {| valid := []; effect := t |} |} + | false => identity_reduce t + end + | _ => identity_reduce t + end. +Obligation 1. + unfold match_pseudo_term, allvalid; simpl; wlp_simplify; congruence. +Qed. +Obligation 2. + unfold match_pseudo_term, allvalid; simpl; wlp_simplify. +Qed. +Obligation 3. + intuition congruence. +Qed. + +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..8c9c820f --- /dev/null +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -0,0 +1,1108 @@ +(** 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. + +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 Type ImpSimuInterface. + +Declare Module CoreL: ISeqLanguage. +Import CoreL. +Import Terms. + +Parameter bblock_simu_test: (forall t : term, reduction t) -> bblock -> bblock -> ?? bool. + +Parameter bblock_simu_test_correct: forall (reduce: forall t, reduction t) (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 + : (forall t : term, reduction t) -> + (R.t -> ?? pstring) -> + (op -> ?? pstring) -> bblock -> bblock -> ?? bool. + +Parameter verb_bblock_simu_test_correct: + forall (reduce: forall t, reduction t) + (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 Dict. + +Import ST. + +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: forall t, reduction t. + +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}. + +Coercion hpost: hsmem >-> Dict.t. + +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 = smem_eval ge d x m. +Proof. + unfold hsmem_get, smem_eval, smem_get; destruct (Dict.get d x); wlp_simplify. +Qed. +Global Opaque hsmem_get. +Hint Resolve hsmem_get_correct: wlp. + +Definition smem_model ge (d: smem) (hd:hsmem): Prop := + (forall m, allvalid ge hd.(hpre) m <-> svalid ge d m) + /\ (forall m x, svalid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). + +Lemma smem_model_svalid_alt ge d hd: smem_model ge d hd -> + forall m x, svalid ge d m -> smem_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. rewrite H2; auto. + unfold svalid 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 -> smem_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. eapply smem_model_svalid_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, svalid ge d m -> term_eval ge ht m = 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 svalid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold svalid in PRE; tauto. } + unfold allvalid in * |- *; simpl. + intuition (subst; eauto). + + eapply svalid_set_proof; eauto. + erewrite <- EQT; eauto. + + exploit svalid_set_decompose_1; eauto. + intros X1; exploit svalid_set_decompose_2; eauto. + rewrite <- EQT; eauto. + + exploit svalid_set_decompose_1; eauto. + - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. + Local Hint Resolve svalid_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_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 -> smem_eval ge hd1 x m = smem_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. + unfold allvalid; induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). + intros REC ge m; rewrite REC; clear IHl' REC. 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 _ _ => + DO ot <~ hsmem_get hd x;; + DO b <~ phys_eq ot ht;; + if b then + RET (hd.(hpost)) + 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, smem_eval ge d y m = smem_eval ge (Dict.set hd x ht) y m. +Proof. + destruct ht; wlp_simplify. + unfold smem_eval at 2; unfold smem_get; simpl; case (R.eq_dec x y). + - intros; subst. rewrite Dict.set_spec_eq. congruence. + - intros; rewrite Dict.set_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.(valid) 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, svalid ge d m -> term_eval ge ht m = 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. + unfold allvalid; 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 smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. + erewrite LIFT, EFFECT; eauto. + + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. + * destruct (ALLVALID ht); simpl; auto. +Qed. +Local Hint Resolve hsmem_set_correct: wlp. +Global Opaque hsmem_set. + +Lemma exp_hterm_correct ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + forall m, svalid ge d m -> svalid 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, svalid ge d m -> svalid 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 hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := + match i with + | nil => RET hd + | (x, e)::i' => + DO nd <~ hsmem_set hd x (exp_term e hd hod);; + 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, svalid ge d m -> svalid ge od m) -> smem_model ge (inst_smem i d od) hd'. +Proof. + Local Hint Resolve svalid_set_proof. + 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 hbblock_smem_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;; + hbblock_smem_rec p' d' + end. + +Lemma hbblock_smem_rec_correct p: forall hd, + WHEN hbblock_smem_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 hbblock_smem_rec. +Local Hint Resolve hbblock_smem_rec_correct: wlp. + + +Definition hbblock_smem: bblock -> ?? hsmem + := fun p => hbblock_smem_rec p {| hpre:= nil ; hpost := Dict.empty |}. + +Lemma hbblock_smem_correct p: + WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Proof. + unfold bblock_smem; wlp_simplify. eapply H. clear H. + unfold smem_model, svalid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. +Qed. +Global Opaque hbblock_smem. + +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 smem_eval_intro (d1 d2: hsmem): + (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, smem_eval ge d1 x m = smem_eval ge d2 x m). +Proof. + unfold smem_eval, smem_get; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. +Qed. + +Local Hint Resolve hbblock_smem_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 <~ hbblock_smem 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 <~ hbblock_smem 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. + + intros m; rewrite <- EQPRE1, <- EQPRE2. + unfold incl, allvalid in * |- *; intuition eauto. + + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. + erewrite smem_eval_intro; eauto. + erewrite <- EQPRE2; auto. + erewrite <- EQPRE1 in VALID. + unfold incl, allvalid 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 hht: hashH term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. +Definition hlht: hashH 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. + +Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := + DO log <~ count_logger ();; + DO hco_term <~ mk_annot (hCons hht);; + DO hco_list <~ mk_annot (hCons hlht);; + 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. + +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 hht);; + DO hco_list <~ mk_annot (hCons hlht);; + 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 hht);; + DO hco_list <~ mk_annot (hCons hlht);; + DO result2 <~ 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_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. + +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/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..637e8296 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -99,41 +99,101 @@ Hint Resolve assert_list_incl_correct. 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}, (hashH 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} (hh: hashH A): ?? (hashConsing A) := + DO hco <~ xhCons hh ;; 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 hh 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 (hh: hashH A): + WHEN hCons hh ~> hco THEN + (forall x y, WHEN hh.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hh x)=(ignore_hid hh y)) -> + forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hh x.(hdata)=ignore_hid hh 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) : hashH (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. + 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..477be65c 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 hashH {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 hashH: clear implicits. + +Axiom unknown_hid: hashcode. +Extract Constant unknown_hid => "-1". + +Definition ignore_hid {A} (hh: hashH A) (hv:A) := set_hid hh 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..3994cae6 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) (hh:a hashH) = + (* 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 = hh.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 = hh.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.(hh.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..9f5eca89 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 hashH -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index d1971e57..22809095 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. diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v new file mode 100644 index 00000000..45afd830 --- /dev/null +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -0,0 +1,428 @@ +(** A theory for checking/proving simulation by symbolic execution. + +*) + + +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. +Require Import List. +Require Import ImpPrelude. +Import HConsingDefs. + +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. + + +Module SimuTheory (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). + +Export L. +Export LP. +Export Terms. + +(* 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: Dict.t term}. + +Coercion post: smem >-> Dict.t. + +(** initial symbolic memory *) +Definition smem_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. + +Definition smem_get (d:Dict.t term) x := + match Dict.get d x with + | None => Input x unknown_hid + | Some t => t + end. + +Fixpoint exp_term (e: exp) (d old: Dict.t term): term := + match e with + | PReg x => smem_get d x + | Op o le => App o (list_exp_term le d old) unknown_hid + | Old e => exp_term e old old + end +with list_exp_term (le: list_exp) (d old: Dict.t term) : list_term := + match le with + | Enil => LTnil unknown_hid + | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) unknown_hid + | LOld le => list_exp_term le old old + end. + +(** evaluation of the post-condition *) +Definition smem_eval ge (d: Dict.t term) x (m:mem) := + term_eval ge (smem_get d x) m. + +(** assignment of the symbolic memory *) +Definition smem_set (d:smem) x (t:term) := + {| pre:=(fun ge m => (smem_eval ge d x m) <> None /\ (d.(pre) ge m)); + post:=Dict.set d x t |}. + +Section SIMU_THEORY. + +Variable ge: genv. + +Lemma set_spec_eq d x t m: + smem_eval ge (smem_set d x t) x m = term_eval ge t m. +Proof. + unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. +Qed. + +Lemma set_spec_diff d x y t m: + x <> y -> smem_eval ge (smem_set d x t) y m = smem_eval ge d y m. +Proof. + intros; unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. +Qed. + +Lemma smem_eval_empty x m: smem_eval ge smem_empty x m = Some (m x). +Proof. + unfold smem_eval, smem_get; rewrite Dict.empty_spec; simpl; auto. +Qed. + +Hint Rewrite set_spec_eq smem_eval_empty: dict_rw. + +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. + +Local Hint Resolve smem_eval_empty. + +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. + +Lemma term_eval_exp e (od:smem) m0 old: + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall d m1, + (forall x, smem_eval ge (d:smem) x m0 = Some (m1 x)) -> + term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. +Proof. + unfold smem_eval in * |- *; intro H. + induction e using exp_mut with + (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (smem_get 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, + pre (inst_smem i d old) ge m0 -> + smem_eval ge d x m0 = None -> + smem_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. + destruct (R.eq_dec x y). + * subst; autorewrite with dict_rw. + generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold smem_set; simpl; intuition congruence. + * rewrite set_spec_diff; auto. +Qed. + +Lemma block_smem_rec_abort p m0 x: forall d, + pre (bblock_smem_rec p d) ge m0 -> + smem_eval ge d x m0 = None -> + smem_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, smem_eval ge od x m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + inst_run ge i m1 old = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + forall x, smem_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; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. +Qed. + +Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), + run ge p m1 = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x). +Proof. + Local Hint Resolve inst_smem_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_smem_Some_correct1 p m0 m1: + run ge p m0 = Some m1 + -> forall x, smem_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, smem_eval ge od x m0 = Some (old x)) -> + forall m1 d, pre (inst_smem i d od) ge m0 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + inst_run ge i m1 old = None -> exists x, smem_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; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + intuition. + constructor 1 with (x:=x); simpl. + apply inst_smem_abort; auto. + autorewrite with dict_rw. + erewrite term_eval_exp; eauto. +Qed. + +Lemma inst_smem_Some_correct2 i m0 old (od: smem): + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall (m1 m2: mem) d, + pre (inst_smem i d od) ge m0 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, smem_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; destruct (R.eq_dec x x0). + * subst. autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + generalize (H x). + rewrite inst_smem_abort; discriminate || auto. + autorewrite with dict_rw. + 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, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, smem_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 (smem_get (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, smem_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, smem_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, smem_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; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. +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, smem_eval ge d x m0 = Some (m1 x)) -> + pre (bblock_smem_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_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 svalid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. + +Theorem bblock_smem_simu p1 p2: + (forall m, svalid ge (bblock_smem p1) m -> svalid ge (bblock_smem p2) m) -> + (forall m0 x m1, svalid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> + smem_eval ge (bblock_smem p2) x m0 = Some m1) -> + bblock_simu ge p1 p2. +Proof. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. + unfold svalid; intros INCL EQUIV m DONTFAIL. + destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. + assert (X: forall x, smem_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; apply EQUIV; intuition eauto. + congruence. +Qed. + +Lemma svalid_set_decompose_1 d t x m: + svalid ge (smem_set d x t) m -> svalid ge d m. +Proof. + unfold svalid; 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 svalid_set_decompose_2 d t x m: + svalid ge (smem_set d x t) m -> term_eval ge t m <> None. +Proof. + unfold svalid; intros ((PRE1 & PRE2) & VALID) H. + generalize (VALID x); autorewrite with dict_rw. + tauto. +Qed. + +Lemma svalid_set_proof d x t m: + svalid ge d m -> term_eval ge t m <> None -> svalid ge (smem_set d x t) m. +Proof. + unfold svalid; 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 SIMU_THEORY. + +End SimuTheory. + +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 -- cgit From e9e83f59ed2b1087ea974e7112abf71d8eb4195b Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 26 May 2019 15:00:35 +0200 Subject: slightly more efficient version --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 10 ++-- mppa_k1c/abstractbb/ImpSimuTest.v | 89 +++++++++++++++++++++------- mppa_k1c/abstractbb/SeqSimuTheory.v | 26 ++++---- 3 files changed, 85 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index f381c810..8ee04f44 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -306,12 +306,12 @@ Definition list_term_get_hid (l: list_term): hashcode := Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. Record pseudo_term: Type := { - valid: list term; + mayfail: list term; effect: term }. Definition match_pseudo_term (t: term) (pt: pseudo_term) := - (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(valid) m) + (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). Import ImpCore.Notations. @@ -323,7 +323,7 @@ Record reduction (t:term):= { }. Hint Resolve result_correct: wlp. -Program Definition identity_reduce (t: term): reduction t := {| result := RET {| valid := [t]; effect := t |} |}. +Program Definition identity_reduce (t: term): reduction t := {| result := RET {| mayfail := [t]; effect := t |} |}. Obligation 1. unfold match_pseudo_term, allvalid; wlp_simplify; congruence. Qed. @@ -331,9 +331,9 @@ Global Opaque identity_reduce. Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := match t with - | Input x _ => {| result := RET {| valid := []; effect := t |} |} + | Input x _ => {| result := RET {| mayfail := []; effect := t |} |} | o @ [] => match is_constant o with - | true => {| result := RET {| valid := []; effect := t |} |} + | true => {| result := RET {| mayfail := []; effect := t |} |} | false => identity_reduce t end | _ => identity_reduce t diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 8c9c820f..13af4289 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -231,20 +231,20 @@ Global Opaque hsmem_get. Hint Resolve hsmem_get_correct: wlp. Definition smem_model ge (d: smem) (hd:hsmem): Prop := - (forall m, allvalid ge hd.(hpre) m <-> svalid ge d m) - /\ (forall m x, svalid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). + (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) + /\ (forall m x, smem_valid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). -Lemma smem_model_svalid_alt ge d hd: smem_model ge d hd -> - forall m x, svalid ge d m -> smem_eval ge hd x m <> None. +Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> + forall m x, smem_valid ge d m -> smem_eval ge hd x m <> None. Proof. intros (H1 & H2) m x H. rewrite H2; auto. - unfold svalid in H. intuition eauto. + 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 -> smem_eval ge hd x m <> None. Proof. - intros (H1 & H2) m x H. eapply smem_model_svalid_alt. + intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. - split; eauto. - rewrite <- H1; auto. Qed. @@ -254,24 +254,24 @@ Definition naive_set (hd:hsmem) x (t:term) := Lemma naive_set_correct hd x ht ge d t: smem_model ge d hd -> - (forall m, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = 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 svalid in PRE; tauto. } - assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold svalid in PRE; tauto. } + 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, smem_eval ge d x m <> None). { unfold smem_valid in PRE; tauto. } unfold allvalid in * |- *; simpl. intuition (subst; eauto). - + eapply svalid_set_proof; eauto. + + eapply smem_valid_set_proof; eauto. erewrite <- EQT; eauto. - + exploit svalid_set_decompose_1; eauto. - intros X1; exploit svalid_set_decompose_2; eauto. + + exploit smem_valid_set_decompose_1; eauto. + intros X1; exploit smem_valid_set_decompose_2; eauto. rewrite <- EQT; eauto. - + exploit svalid_set_decompose_1; eauto. + + exploit smem_valid_set_decompose_1; eauto. - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. - Local Hint Resolve svalid_set_decompose_1. + Local Hint Resolve smem_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. @@ -387,7 +387,7 @@ Global Opaque smart_set. Definition hsmem_set (hd:hsmem) x (t:term) := DO pt <~ reduce t;; - DO lht <~ hterm_append pt.(valid) hd.(hpre);; + 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;; @@ -396,7 +396,7 @@ Definition hsmem_set (hd:hsmem) x (t:term) := 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, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = term_eval ge t m) -> smem_model ge (smem_set d x t) nhd. Proof. intros; wlp_simplify. @@ -418,34 +418,79 @@ 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, svalid ge d m -> svalid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. + 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, svalid ge d m -> svalid 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); + 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 hexp_term (e: exp) (d od: hsmem): ?? term := + match e with + | PReg x => hsmem_get d x + | Op o le => + DO lt <~ hlist_exp_term le d od;; + hApp o lt + | Old e => hexp_term e od od + end +with hlist_exp_term (le: list_exp) (d od: hsmem): ?? list_term := + match le with + | Enil => hLTnil tt + | Econs e le' => + DO t <~ hexp_term e d od;; + DO lt <~ hlist_exp_term le' d od;; + hLTcons t lt + | LOld le => hlist_exp_term le od od + end. + +Lemma hexp_term_correct_x ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + WHEN hexp_term e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t 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 -> + WHEN hlist_exp_term le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = list_term_eval ge (list_exp_term le d od) m); + unfold smem_model, smem_eval in * |- * ; simpl; wlp_simplify. + - rewrite H1, <- H4; auto. + - rewrite H4, <- H0; simpl; auto. + - rewrite H5, <- H0, <- H4; simpl; auto. +Qed. +Global Opaque hexp_term. + +Lemma hexp_term_correct e hd hod: + WHEN hexp_term 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 = term_eval ge (exp_term e d od) m. +Proof. + unfold wlp; intros; eapply hexp_term_correct_x; eauto. +Qed. +Hint Resolve hexp_term_correct: wlp. Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := match i with | nil => RET hd | (x, e)::i' => - DO nd <~ hsmem_set hd x (exp_term e hd hod);; + DO ht <~ hexp_term 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, svalid ge d m -> svalid ge od m) -> smem_model ge (inst_smem i d od) hd'. + 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 svalid_set_proof. + Local Hint Resolve smem_valid_set_proof. induction i; simpl; wlp_simplify; eauto 15 with wlp. Qed. Global Opaque hinst_smem. @@ -479,7 +524,7 @@ Lemma hbblock_smem_correct p: WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, svalid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + unfold smem_model, smem_valid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. Qed. Global Opaque hbblock_smem. diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 45afd830..8b6a372a 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -337,16 +337,16 @@ Proof. unfold smem_empty; simpl. auto. Qed. -Definition svalid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. +Definition smem_valid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. Theorem bblock_smem_simu p1 p2: - (forall m, svalid ge (bblock_smem p1) m -> svalid ge (bblock_smem p2) m) -> - (forall m0 x m1, svalid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> + (forall m, smem_valid ge (bblock_smem p1) m -> smem_valid ge (bblock_smem p2) m) -> + (forall m0 x m1, smem_valid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> smem_eval ge (bblock_smem p2) x m0 = Some m1) -> bblock_simu ge p1 p2. Proof. Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. - unfold svalid; intros INCL EQUIV m DONTFAIL. + unfold smem_valid; intros INCL EQUIV m DONTFAIL. destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. assert (X: forall x, smem_eval ge (bblock_smem p1) x m = Some (m1 x)); eauto. eapply bblock_smem_Some_correct2; eauto. @@ -356,28 +356,28 @@ Proof. congruence. Qed. -Lemma svalid_set_decompose_1 d t x m: - svalid ge (smem_set d x t) m -> svalid ge d m. +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 svalid; intros ((PRE1 & PRE2) & VALID); split. + 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 svalid_set_decompose_2 d t x m: - svalid ge (smem_set d x t) m -> term_eval ge t m <> None. +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 svalid; intros ((PRE1 & PRE2) & VALID) H. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. generalize (VALID x); autorewrite with dict_rw. tauto. Qed. -Lemma svalid_set_proof d x t m: - svalid ge d m -> term_eval ge t m <> None -> svalid ge (smem_set d x t) m. +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 svalid; intros (PRE & VALID) PREt. split. + unfold smem_valid; intros (PRE & VALID) PREt. split. + split; auto. + intros x0; case (R.eq_dec x x0). - intros; subst; autorewrite with dict_rw. auto. -- cgit From 0bd3d3c9cb1445a588ed4f254c5e036a213801c1 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 28 May 2019 07:13:39 +0200 Subject: simpler definition of reduce --- mppa_k1c/Asmblockdeps.v | 19 ++++- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 123 ++++++++++++++++++++------- mppa_k1c/abstractbb/ImpSimuTest.v | 39 +++++---- 3 files changed, 133 insertions(+), 48 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e0aaee58..55a02633 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1579,20 +1579,31 @@ Definition is_constant (o: op): bool := | _ => false end. -Program Definition failsafe_reduce := Terms.failsafe_reduce is_constant. -Obligation 1. +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 - IST.verb_bblock_simu_test failsafe_reduce 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 - IST.bblock_simu_test failsafe_reduce (trans_block p1) (trans_block p2). + IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 8ee04f44..43c70ae5 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,5 +1,6 @@ (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) +Require Import Setoid. Require Import ImpPrelude. Module Type PseudoRegisters. @@ -303,50 +304,114 @@ Definition list_term_get_hid (l: list_term): hashcode := end. -Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. +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 := { +Record pseudo_term: Type := intro_fail { mayfail: list term; effect: term }. -Definition match_pseudo_term (t: term) (pt: pseudo_term) := +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). -Import ImpCore.Notations. -Local Open Scope impure_scope. +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. -Record reduction (t:term):= { - result:> ?? pseudo_term; - result_correct: WHEN result ~> pt THEN match_pseudo_term t pt; -}. -Hint Resolve result_correct: wlp. +Definition identity_fail (t: term):= intro_fail [t] t. -Program Definition identity_reduce (t: term): reduction t := {| result := RET {| mayfail := [t]; effect := t |} |}. -Obligation 1. - unfold match_pseudo_term, allvalid; wlp_simplify; congruence. +Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). +Proof. + eapply intro_fail_correct; simpl; tauto. Qed. -Global Opaque identity_reduce. +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. -Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := - match t with - | Input x _ => {| result := RET {| mayfail := []; effect := t |} |} - | o @ [] => match is_constant o with - | true => {| result := RET {| mayfail := []; effect := t |} |} - | false => identity_reduce t - end - | _ => identity_reduce t - end. -Obligation 1. - unfold match_pseudo_term, allvalid; simpl; wlp_simplify; congruence. +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. -Obligation 2. - unfold match_pseudo_term, allvalid; simpl; wlp_simplify. + +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. -Obligation 3. - intuition congruence. +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_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 (XV & XE) (YV & YE). + split; intros ge m; try (simpl; auto; fail). + generalize (XV ge m) (YV ge m); rewrite !allvalid_extensionality; simpl. clear XV XE YV YE. + 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. +Hint Resolve app_fail_correct: wlp. +Extraction Inline app_fail. +Global Opaque 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. diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 13af4289..8f6b05b7 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -67,20 +67,20 @@ Declare Module CoreL: ISeqLanguage. Import CoreL. Import Terms. -Parameter bblock_simu_test: (forall t : term, reduction t) -> bblock -> bblock -> ?? bool. +Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool. -Parameter bblock_simu_test_correct: forall (reduce: forall t, reduction t) (p1 p2 : bblock), +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 - : (forall t : term, reduction t) -> + : reduction -> (R.t -> ?? pstring) -> (op -> ?? pstring) -> bblock -> bblock -> ?? bool. Parameter verb_bblock_simu_test_correct: - forall (reduce: forall t, reduction t) + forall reduce (string_of_name : R.t -> ?? pstring) (string_of_op : op -> ?? pstring) (p1 p2 : bblock), @@ -128,7 +128,7 @@ Module D:=ImpPrelude.Dict. Section SimuWithReduce. -Variable reduce: forall t, reduction t. +Variable reduce: reduction. Section CanonBuilding. @@ -230,6 +230,8 @@ 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 -> smem_eval ge hd x m = (smem_eval ge d x m)). @@ -262,7 +264,7 @@ Proof. 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, smem_eval ge d x m <> None). { unfold smem_valid in PRE; tauto. } - unfold allvalid in * |- *; simpl. + rewrite !allvalid_extensionality in * |- *; simpl. intuition (subst; eauto). + eapply smem_valid_set_proof; eauto. erewrite <- EQT; eauto. @@ -351,8 +353,10 @@ 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. - unfold allvalid; induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). - intros REC ge m; rewrite REC; clear IHl' REC. intuition (subst; eauto with wlp 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. @@ -406,14 +410,14 @@ Proof. eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. destruct H as (VALID & EFFECT); split. - intros; rewrite APPEND, <- VALID. - unfold allvalid; simpl; intuition (subst; eauto). + 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 smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. erewrite LIFT, EFFECT; eauto. + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. - * destruct (ALLVALID ht); simpl; auto. + * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. Qed. Local Hint Resolve hsmem_set_correct: wlp. Global Opaque hsmem_set. @@ -520,11 +524,13 @@ Local Hint Resolve hbblock_smem_rec_correct: wlp. Definition hbblock_smem: bblock -> ?? hsmem := fun p => hbblock_smem_rec p {| hpre:= nil ; hpost := Dict.empty |}. +Transparent allvalid. + Lemma hbblock_smem_correct p: WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, smem_valid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + unfold smem_model, smem_valid, smem_eval, smem_get; simpl; intuition; rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. Qed. Global Opaque hbblock_smem. @@ -649,12 +655,14 @@ Obligation 1. destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. apply bblock_smem_simu; auto. + intros m; rewrite <- EQPRE1, <- EQPRE2. - unfold incl, allvalid in * |- *; intuition eauto. + rewrite ! allvalid_extensionality. + unfold incl in * |- *; intuition eauto. + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. erewrite smem_eval_intro; eauto. erewrite <- EQPRE2; auto. erewrite <- EQPRE1 in VALID. - unfold incl, allvalid in * |- *; intuition eauto. + rewrite ! allvalid_extensionality in * |- *. + unfold incl in * |- *; intuition eauto. Qed. Theorem g_bblock_simu_test_correct p1 p2: @@ -1011,9 +1019,10 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO cr <~ make_cref None;; DO hco_term <~ mk_annot (hCons hht);; DO hco_list <~ mk_annot (hCons hlht);; - DO result2 <~ g_bblock_simu_test + DO result2 <~ g_bblock_simu_test (log_assign dict_info log1) - (log_new_term (msg_term cr)) + (*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 _ -- cgit From 9f111987bb820d2a2b92441752c0d5c0c5df8033 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 28 May 2019 17:35:03 +0200 Subject: minor change in auxiliary lemma --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 32 ++++++++++++++++++---------- 1 file changed, 21 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 43c70ae5..5c94d435 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -325,6 +325,13 @@ Record pseudo_term: Type := intro_fail { 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). @@ -383,15 +390,12 @@ 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_correct l pt t1 t2: - match_pt t1 pt -> - match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> - match_pt t2 (app_fail l pt). +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. - unfold match_pt in * |- *. - intros (XV & XE) (YV & YE). - split; intros ge m; try (simpl; auto; fail). - generalize (XV ge m) (YV ge m); rewrite !allvalid_extensionality; simpl. clear XV XE YV YE. + 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. @@ -399,10 +403,16 @@ Proof. * 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. -Hint Resolve app_fail_correct: wlp. -Extraction Inline app_fail. -Global Opaque app_fail. +Local Hint Resolve app_fail_allvalid_correct. +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. -- cgit From 83cc11add90eea576a798bacf821a70a28d4d9cc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 00:25:01 +0200 Subject: to be able to use DDR we need 8-byte pointers in jump tables --- mppa_k1c/TargetPrinter.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 15f05960..96779517 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -173,10 +173,10 @@ module Target (*: TARGET*) = (* Associate labels to floating-point constants and to symbols. *) let print_tbl oc (lbl, tbl) = - fprintf oc " .balign 4\n"; + fprintf oc " .balign 8\n"; fprintf oc "%a:\n" label lbl; List.iter - (fun l -> fprintf oc " .4byte %a\n" + (fun l -> fprintf oc " .8byte %a\n" print_label l) tbl @@ -408,9 +408,9 @@ module Target (*: TARGET*) = fprintf oc "%s jumptable [ " comment; List.iter (fun l -> fprintf oc "%a " print_label l) tbl; fprintf oc "]\n"; - fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; - fprintf oc " lwz.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; - fprintf oc " igoto %a\n ;;\n" ireg base_reg; + fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; + fprintf oc " ld.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; + fprintf oc " igoto %a\n ;;\n" ireg base_reg; section oc Section_jumptable; print_tbl oc (lbl, tbl); section oc Section_text -- cgit From b557706f77ca4cf0721dfb4d911207a2fae12411 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 06:38:53 +0200 Subject: error in the classification of Srsw --- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9067f8e1..7015fd5f 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -603,9 +603,9 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) - | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) + | Srsw | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | 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 -> -- cgit From 487fc42595bb43450f2b0b5a49b4edbc22892b9f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Jun 2019 22:26:06 +0200 Subject: rm old select/selectl/selectf/selectfs --- mppa_k1c/Archi.v | 23 ++-- mppa_k1c/Asmblockgen.v | 21 ---- mppa_k1c/Asmblockgenproof1.v | 244 ------------------------------------------- mppa_k1c/ExtValues.v | 6 +- mppa_k1c/Machregs.v | 1 - mppa_k1c/NeedOp.v | 182 -------------------------------- mppa_k1c/Op.v | 135 ++---------------------- mppa_k1c/SelectLong.vp | 19 ---- mppa_k1c/SelectLongproof.v | 75 ------------- mppa_k1c/SelectOp.vp | 47 +-------- mppa_k1c/SelectOpproof.v | 97 ++++------------- mppa_k1c/ValueAOp.v | 44 -------- 12 files changed, 44 insertions(+), 850 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index bbe66c5b..113f5d51 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for RISC-V *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := true. @@ -41,23 +41,26 @@ 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 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := false. (**r always choose first NaN *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := false. (**r always choose first NaN *) +(* TODO check *) +Definition fpu_returns_default_qNaN := 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_binop_pl_64 + default_nan_32 choose_binop_pl_32 float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 941796cd..33fa39b5 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -784,31 +784,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); diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 3c1162bd..8125741b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1719,250 +1719,6 @@ Opaque Int.eq. - (* 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. Qed. (** Memory accesses *) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 155afa83..8e6aa028 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -287,10 +287,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. @@ -367,7 +367,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. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index db3dfe64..4e8eedda 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,7 +216,6 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl - | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 5ba9851f..746b21a6 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -129,7 +129,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) end. @@ -277,179 +276,6 @@ 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. -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. -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. -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. -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. -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. -Qed. Remark default_idem: forall nv, default (default nv) = default nv. Proof. @@ -514,14 +340,6 @@ Proof. 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. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4df157b0..24572e13 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -204,10 +204,6 @@ 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) @@ -304,24 +300,24 @@ 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 := +Definition eval_selecti (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 := +Definition eval_selecti2 (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). +Lemma eval_selecti_to2: forall cond v0 v1 vselect m, + (eval_selecti cond v0 v1 vselect m) = + (eval_selecti2 cond v0 v1 vselect m). Proof. intros. - unfold eval_select2. + unfold eval_selecti2. destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. Qed. @@ -526,10 +522,6 @@ 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) @@ -734,12 +726,7 @@ 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) @@ -1021,43 +1008,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 _ _). @@ -1250,19 +1200,6 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => 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. @@ -1274,7 +1211,7 @@ 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. + unfold eval_selecti, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1668,62 +1605,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. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 4e369e11..981c796c 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -306,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 @@ -332,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 78a2bb31..ada02585 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -660,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 23d234aa..219a462b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,33 +66,8 @@ Section SELECT. Context {hf: helper_functions}. (** 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. +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := None. + (** ** Constants **) @@ -349,24 +324,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)) => diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index a5154611..26f1bb89 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -609,7 +609,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. @@ -637,7 +637,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. @@ -756,83 +756,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. @@ -1488,6 +1411,22 @@ Proof. - constructor; auto. Qed. +(* ternary *) + +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. + discriminate. +Qed. + (* floating-point division *) Theorem eval_divf_base: forall le a b x y, diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f41dae63..f0cdf24e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -282,10 +282,6 @@ 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 @@ -411,46 +407,6 @@ Proof. + eauto with va. + destruct a1; destruct shift; reflexivity. - 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. (* extfz *) - unfold extfz, eval_static_extfz. -- cgit From 0daaa4c00119fe19872bab38aacf01c34d465c5f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 07:15:19 +0200 Subject: Osel operation (not yet compiled) --- mppa_k1c/NeedOp.v | 7 +++++++ mppa_k1c/Op.v | 34 ++++++++++++++++++++++++++++------ mppa_k1c/ValueAOp.v | 29 ++++------------------------- 3 files changed, 39 insertions(+), 31 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 746b21a6..047c180a 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 @@ -131,6 +132,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ocmp c => needs_of_condition c | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) + | Osel c ty => nv :: nv :: needs_of_condition0 c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -340,6 +342,11 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. + (* select *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto. + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 24572e13..c7c04d83 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -209,7 +209,8 @@ Inductive operation : Type := | 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). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -250,7 +251,7 @@ 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 eq_shift1_4; 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. @@ -528,6 +529,7 @@ Definition eval_operation | (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) | _, _ => None end. @@ -731,6 +733,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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) end. (* FIXME: two Tptr ?! *) @@ -1040,6 +1043,10 @@ 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. Qed. End SOUNDNESS. @@ -1200,6 +1207,10 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 + + | Osel (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ => Archi.ptr64 + | _ => false end. @@ -1208,10 +1219,13 @@ 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_selecti, 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. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1645,6 +1659,14 @@ 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. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f0cdf24e..d24cebcc 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -51,30 +51,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 @@ -288,6 +264,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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 | _, _ => Vbot end. @@ -367,7 +344,7 @@ Theorem eval_static_operation_sound: 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, addx, revsubx, addxl, revsubxl; 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. @@ -442,6 +419,8 @@ 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. Qed. End SOUNDNESS. -- cgit From 30f549e4e04567e35fb6a4eda269132f6cd22dd1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 07:26:55 +0200 Subject: Osel is output = 1st input --- mppa_k1c/Machregs.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 4e8eedda..ee3a63c7 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,6 +216,7 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl + | Osel _ _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. -- cgit From eec7948bd0204787ad8ddde70c5a28fdfd62356a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 11:25:11 +0200 Subject: Osel -> assembleur --- mppa_k1c/Asmblockgen.v | 71 ++++++++++++++++++++++++----------- mppa_k1c/Asmblockgenproof1.v | 57 ++++++++++++++++++++++++++++ mppa_k1c/Op.v | 88 +++----------------------------------------- 3 files changed, 112 insertions(+), 104 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 33fa39b5..72d7394b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -334,6 +334,47 @@ 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 => 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. + +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 transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -377,28 +418,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]. *) @@ -821,6 +840,14 @@ 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) + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8125741b..86e640c9 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1649,6 +1649,25 @@ 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 transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1719,6 +1738,44 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. 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 *. + 1, 2, 3: + destruct c; simpl in *; inv EQ2; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + rewrite Pregmap.gss; + destruct (rs x1); simpl; trivial; + rewrite if_neg; + apply Val.lessdef_normalize. + + destruct c; simpl in *; inv EQ2; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + rewrite Pregmap.gss; + destruct (rs x1); simpl; trivial; + rewrite if_neg; + try apply Val.lessdef_normalize; + + destruct Archi.ptr64; simpl; replace (Int64.eq Int64.zero Int64.zero) with true by reflexivity; simpl; trivial; + destruct (_ || _); trivial; + apply Val.lessdef_normalize. Qed. (** Memory accesses *) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c7c04d83..be7ea812 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -301,90 +301,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_selecti (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 +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. -Definition eval_selecti2 (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_selecti_to2: forall cond v0 v1 vselect m, - (eval_selecti cond v0 v1 vselect m) = - (eval_selecti2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selecti2. - 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 - 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 := -- cgit From 5feecb99712de3604f284e5934aed73f2b606659 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 11:47:14 +0200 Subject: start to have whole path if-conversion? --- mppa_k1c/SelectOp.vp | 5 ++++- mppa_k1c/SelectOpproof.v | 14 +++++++++++++- 2 files changed, 17 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 219a462b..ee614253 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,7 +66,10 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := None. +(** TODO *) +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := + Some (Eop (Osel (Ccomp0 Cne) ty) (e1 ::: e2 ::: + (Eop (Ocmp cond) args) ::: Enil)). (** ** Constants **) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 26f1bb89..7c6dfb7d 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1424,7 +1424,19 @@ Theorem eval_select: eval_expr ge sp e m le a v /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. Proof. - discriminate. + unfold select. + intros until b. + intro Hop; injection Hop; clear Hop; intro; subst a. + intros HeL He1 He2 HeC. + econstructor; split. + { + repeat (try econstructor; try eassumption). + } + apply Val.select_lessdef; trivial. + right. + rewrite HeC. + simpl. + destruct b; reflexivity. Qed. (* floating-point division *) -- cgit From 7c054b47cad2f75efa661b298484dfbfdd976701 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 13:03:38 +0200 Subject: little restructuring --- mppa_k1c/SelectOp.vp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index ee614253..8101a9b0 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,10 +66,11 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -(** TODO *) +Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := + (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). + Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := - Some (Eop (Osel (Ccomp0 Cne) ty) (e1 ::: e2 ::: - (Eop (Ocmp cond) args) ::: Enil)). + Some (select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args)). (** ** Constants **) -- cgit From 2facdc1ec4a51c0eeb31baa299677915e6155ed5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 18:04:47 +0200 Subject: why doesn't it work? --- mppa_k1c/SelectOp.vp | 44 ++++++++- mppa_k1c/SelectOpproof.v | 228 +++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 265 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 8101a9b0..f997d3d7 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -65,12 +65,54 @@ Section SELECT. Context {hf: helper_functions}. +Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := + match cond, args with + | (Ccomp c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 c), e1) + else None + | (Ccomp c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 (swap_comparison c)), e2) + else None + | (Ccompu c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 c), e1) + else None + | (Ccompu c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 (swap_comparison c)), e2) + else None + + | (Ccompl c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 c), e1) + else None + | (Ccompl c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 (swap_comparison c)), e2) + else None + | (Ccomplu c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 c), e1) + else None + | (Ccomplu c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 (swap_comparison c)), e2) + else None + | _, _ => None + end. + (** Ternary operator *) Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := - Some (select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args)). + 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 **) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7c6dfb7d..47b4cbb3 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1412,6 +1412,98 @@ Proof. 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_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. + econstructor; split. + { + unfold select0. + repeat (try econstructor; try eassumption). + } + 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, @@ -1428,15 +1520,139 @@ Proof. intros until b. intro Hop; injection Hop; clear Hop; intro; subst a. intros HeL He1 He2 HeC. - econstructor; split. + unfold cond_to_condition0. + destruct (cond_to_condition0_match cond al). { - repeat (try econstructor; try eassumption). + 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). } - apply Val.select_lessdef; trivial. - right. - rewrite HeC. + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + rewrite <- eval_condition_ccomp_swap. + simpl. + change (Val.cmp_bool (swap_comparison c) v3 (Vint Int.zero)) + with (eval_condition0 (Ccomp0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccomp_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmp_bool (swap_comparison c) v3 (Vint x))). + rewrite Val.swap_cmp_bool. + 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 (Int.eq_dec x Int.zero). + { subst x. + rewrite <- eval_condition_ccompu_swap. + simpl. + change (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 + (Vint Int.zero)) + with (eval_condition0 (Ccompu0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccompu_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vint x))). + rewrite Val.swap_cmpu_bool. + 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. + rewrite <- eval_condition_ccompl_swap. + simpl. + change (Val.cmpl_bool (swap_comparison c) v3 (Vlong Int64.zero)) + with (eval_condition0 (Ccompl0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccompl_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmpl_bool (swap_comparison c) v3 (Vlong x))). + rewrite Val.swap_cmpl_bool. + 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). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + rewrite <- eval_condition_ccomplu_swap. + simpl. + change (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong Int64.zero)) + with (eval_condition0 (Ccomplu0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccomplu_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong x))). + rewrite Val.swap_cmplu_bool. + eapply eval_select0; repeat (try econstructor; try eassumption). + } + TrivialExists. + repeat (try econstructor; try eassumption). simpl. - destruct b; reflexivity. + f_equal. + rewrite HeC. + destruct b; simpl; reflexivity. Qed. (* floating-point division *) -- cgit From 74d93ac506f605a1c27179cb7acca2d033aca94b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 18:16:30 +0200 Subject: shortcut cmove works --- mppa_k1c/SelectOp.vp | 27 +++++-------------- mppa_k1c/SelectOpproof.v | 69 ------------------------------------------------ 2 files changed, 7 insertions(+), 89 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index f997d3d7..01985060 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -67,39 +67,26 @@ Context {hf: helper_functions}. Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := match cond, args with - | (Ccomp c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + | (Ccompimm c x), (e1 ::: Enil) => if Int.eq_dec x Int.zero then Some ((Ccomp0 c), e1) else None - | (Ccomp c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccomp0 (swap_comparison c)), e2) - else None - | (Ccompu c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + + | (Ccompuimm c x), (e1 ::: Enil) => if Int.eq_dec x Int.zero then Some ((Ccompu0 c), e1) else None - | (Ccompu c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccompu0 (swap_comparison c)), e2) - else None - | (Ccompl c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + | (Ccomplimm c x), (e1 ::: Enil) => if Int64.eq_dec x Int64.zero then Some ((Ccompl0 c), e1) else None - | (Ccompl c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccompl0 (swap_comparison c)), e2) - else None - | (Ccomplu c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + + | (Ccompluimm c x), (e1 ::: Enil) => if Int64.eq_dec x Int64.zero then Some ((Ccomplu0 c), e1) else None - | (Ccomplu c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccomplu0 (swap_comparison c)), e2) - else None + | _, _ => None end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 47b4cbb3..4047048c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1536,23 +1536,6 @@ Proof. 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. - rewrite <- eval_condition_ccomp_swap. - simpl. - change (Val.cmp_bool (swap_comparison c) v3 (Vint Int.zero)) - with (eval_condition0 (Ccomp0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccomp_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmp_bool (swap_comparison c) v3 (Vint x))). - rewrite Val.swap_cmp_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1567,24 +1550,6 @@ Proof. 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 (Int.eq_dec x Int.zero). - { subst x. - rewrite <- eval_condition_ccompu_swap. - simpl. - change (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 - (Vint Int.zero)) - with (eval_condition0 (Ccompu0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccompu_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vint x))). - rewrite Val.swap_cmpu_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1599,23 +1564,6 @@ Proof. 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. - rewrite <- eval_condition_ccompl_swap. - simpl. - change (Val.cmpl_bool (swap_comparison c) v3 (Vlong Int64.zero)) - with (eval_condition0 (Ccompl0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccompl_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmpl_bool (swap_comparison c) v3 (Vlong x))). - rewrite Val.swap_cmpl_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1630,23 +1578,6 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - { - InvEval. - rewrite <- HeC. - destruct (Int64.eq_dec x Int64.zero). - { subst x. - rewrite <- eval_condition_ccomplu_swap. - simpl. - change (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong Int64.zero)) - with (eval_condition0 (Ccomplu0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccomplu_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong x))). - rewrite Val.swap_cmplu_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } TrivialExists. repeat (try econstructor; try eassumption). simpl. -- cgit From ed95a6a6fbdd915e361e696d4bf72e5a545b965e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 20:00:47 +0200 Subject: shortcuts for cmove --- mppa_k1c/Asmblockgen.v | 8 +++---- mppa_k1c/Asmblockgenproof1.v | 52 ++++++++++++++++++++++++++++++-------------- 2 files changed, 40 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 72d7394b..04ce13e7 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -342,8 +342,8 @@ Definition btest_for_cmpuwz (c: comparison) := | 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") + | Cle => OK BTweqz + | Cgt => OK BTwnez end. (* CoMPare Unsigned Words to Zero *) @@ -353,8 +353,8 @@ Definition btest_for_cmpudz (c: comparison) := | 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") + | Cle => OK BTdeqz + | Cgt => OK BTdnez end. Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 86e640c9..1ed584e8 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1668,6 +1668,30 @@ 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. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1754,28 +1778,24 @@ Opaque Int.eq. } destruct c0; simpl in *. - 1, 2, 3: - destruct c; simpl in *; inv EQ2; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - rewrite Pregmap.gss; - destruct (rs x1); simpl; trivial; - rewrite if_neg; - apply Val.lessdef_normalize. - + + all: destruct c; simpl in *; inv EQ2; econstructor; split; try (apply exec_straight_one; constructor); split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); unfold Val.select; simpl; rewrite Pregmap.gss; destruct (rs x1); simpl; trivial; - rewrite if_neg; - try apply Val.lessdef_normalize; - - destruct Archi.ptr64; simpl; replace (Int64.eq Int64.zero Int64.zero) with true by reflexivity; simpl; trivial; - destruct (_ || _); trivial; - apply Val.lessdef_normalize. + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. Qed. (** Memory accesses *) -- cgit From ac366a59308ae85a0cbfefb8b9be79763d5c5f91 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 21:16:40 +0200 Subject: added immediate cmove --- mppa_k1c/Asm.v | 9 ++++- mppa_k1c/Asmblockdeps.v | 4 ++ mppa_k1c/Asmblockgenproof1.v | 3 ++ mppa_k1c/Asmvliw.v | 76 +++++++++++++++++++++--------------- mppa_k1c/PostpassSchedulingOracle.ml | 20 +++++++--- mppa_k1c/TargetPrinter.ml | 6 +++ 6 files changed, 80 insertions(+), 38 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e5f81fbb..620aa91e 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -273,6 +273,10 @@ Inductive instruction : Type := | 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 *) @@ -447,10 +451,13 @@ Definition basic_to_instruction (b: basic) := (** 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 Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 616ec6db..265c4e84 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1515,11 +1515,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 := diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1ed584e8..8939cc30 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1759,9 +1759,11 @@ 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. + - (* Osel *) unfold conditional_move in *. destruct (ireg_eq _ _). @@ -1784,6 +1786,7 @@ Opaque Int.eq. econstructor; split; try (apply exec_straight_one; constructor); split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); unfold Val.select; simpl; + unfold cmove, cmoveu; rewrite Pregmap.gss; destruct (rs x1); simpl; trivial; try rewrite int_ltu_to_neq; diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 886228ad..bb6b7132 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -527,10 +527,14 @@ Inductive arith_name_arrr : Type := 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 := @@ -1120,44 +1124,48 @@ Definition arith_eval_rri64 n v 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) | Pmsubw => Val.sub v1 (Val.mul v2 v3) | Pmsubl => Val.subl 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 + | Pcmove bt => cmove bt v1 v2 v3 + | Pcmoveu bt => cmoveu bt v1 v2 v3 end. Definition arith_eval_arr n v1 v2 := @@ -1169,11 +1177,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 := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index af1e8f85..78af896a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -154,7 +154,17 @@ let arith_arrr_str = function | Pmsubl -> "Pmsubl" | Pcmove _ -> "Pcmove" | Pcmoveu _ -> "Pcmoveu" - + +let arith_arri32_str = function + | Pmaddiw -> "Pmaddiw" + | Pcmoveiw _ -> "Pcmoveiw" + | Pcmoveuiw _ -> "Pcmoveuiw" + +let arith_arri64_str = function + | Pmaddil -> "Pmaddil" + | Pcmoveil _ -> "Pcmoveil" + | Pcmoveuil _ -> "Pcmoveuil" + let arith_ri32_str = "Pmake" let arith_ri64_str = "Pmakel" @@ -194,9 +204,9 @@ let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Re 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_arri32_rec i rd rs imm32 = { inst = arith_arri32_str i; 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_arri64_rec i rd rs imm64 = { inst = arith_arri64_str i; 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} @@ -215,8 +225,8 @@ 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} diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 34765726..8365d54f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -717,6 +717,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) = -- cgit From 6064bac57701ba0a12031d43acbe25cb0140730c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 21:42:30 +0200 Subject: begin osel imm --- mppa_k1c/NeedOp.v | 12 ++++++++++++ mppa_k1c/Op.v | 42 +++++++++++++++++++++++++++++++++++++++--- mppa_k1c/ValueAOp.v | 6 ++++++ 3 files changed, 57 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 047c180a..4748f38b 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -133,6 +133,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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 := @@ -347,6 +349,16 @@ Proof. 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 be7ea812..1b3a839f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -210,7 +210,9 @@ Inductive operation : Type := | Oextfsl (stop : Z) (start : Z) | Oinsf (stop : Z) (start : Z) | Oinsfl (stop : Z) (start : Z) - | Osel (c0 : condition0) (ty : typ). + | 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. *) @@ -454,6 +456,8 @@ Definition eval_operation | (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::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) + | Osellimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) | _, _ => None end. @@ -658,6 +662,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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 :: Tint :: arg_type_of_condition0 c :: nil, Tint) + | Osellimm c ty => (Tlong :: Tlong :: arg_type_of_condition0 c :: nil, Tlong) end. (* FIXME: two Tptr ?! *) @@ -971,6 +977,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - 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. End SOUNDNESS. @@ -1132,8 +1146,8 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 - | Osel (Ccompu0 _) _ => negb Archi.ptr64 - | Osel (Ccomplu0 _) _ => Archi.ptr64 + | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64 | _ => false end. @@ -1150,6 +1164,12 @@ Proof. - 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 *) @@ -1591,6 +1611,22 @@ Proof. symmetry. eapply eval_condition0_inj; eassumption. + left. trivial. + + (* Oselimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Osellimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index d24cebcc..daceab8b 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -265,6 +265,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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::v2::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) + | Osellimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) | _, _ => Vbot end. @@ -421,6 +423,10 @@ Proof. + 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. -- cgit From 68a6d0dd0ea5774529d823fb9a9ca981c1ecebb0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 22:58:34 +0200 Subject: osel imm --- mppa_k1c/Asmblockgen.v | 43 ++++++++++++++++++++++++++++++++ mppa_k1c/Asmblockgenproof1.v | 48 ++++++++++++++++++++++++++++++++++++ mppa_k1c/Machregs.v | 2 +- mppa_k1c/Op.v | 12 ++++----- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- mppa_k1c/SelectOp.vp | 10 ++++++-- mppa_k1c/SelectOpproof.v | 19 ++++++-------- mppa_k1c/ValueAOp.v | 4 +-- 8 files changed, 117 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 04ce13e7..e5b9b35a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -375,6 +375,34 @@ Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : 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 @@ -847,6 +875,21 @@ Definition transl_op 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") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8939cc30..bc549b4a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1799,6 +1799,54 @@ Opaque Int.eq. try destruct (_ || _); trivial; try apply Val.lessdef_normalize. + +- (* Oselimm *) + unfold conditional_move_imm32 in *. + destruct c0; simpl in *. + + all: + destruct c; simpl in *; inv EQ0; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + unfold cmove, cmoveu; + rewrite Pregmap.gss; + destruct (rs x0); simpl; trivial; + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. + + +- (* Osellimm *) + unfold conditional_move_imm64 in *. + destruct c0; simpl in *. + + all: + destruct c; simpl in *; inv EQ0; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + unfold cmove, cmoveu; + rewrite Pregmap.gss; + destruct (rs x0); simpl; trivial; + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. + Qed. (** Memory accesses *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ee3a63c7..5a7d42b4 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,7 +216,7 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl - | Osel _ _ + | Osel _ _ | Oselimm _ _ | Osellimm _ _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 1b3a839f..35fbb596 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -456,8 +456,8 @@ Definition eval_operation | (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::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) - | Osellimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) + | 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. @@ -662,8 +662,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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 :: Tint :: arg_type_of_condition0 c :: nil, Tint) - | Osellimm c ty => (Tlong :: Tlong :: arg_type_of_condition0 c :: nil, Tlong) + | 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 ?! *) @@ -1614,7 +1614,7 @@ Proof. (* Oselimm *) - apply Val.select_inject; trivial. - destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + destruct (eval_condition0 _ _ _) eqn:Hcond. + right. symmetry. eapply eval_condition0_inj; eassumption. @@ -1622,7 +1622,7 @@ Proof. (* Osellimm *) - apply Val.select_inject; trivial. - destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + destruct (eval_condition0 _ _ _) eqn:Hcond. + right. symmetry. eapply eval_condition0_inj; eassumption. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 78af896a..6ccc4e97 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -551,7 +551,7 @@ let ab_inst_to_real = function | "Pfixedudrzz" -> Fixedudz | "Pfixeddrzz_i32" -> Fixeddz | "Pfixedudrzz_i32" -> Fixedudz - | "Pcmove" | "Pcmoveu" -> Cmoved + | "Pcmove" | "Pcmoveu" | "Pcmoveiw" | "Pcmoveuiw" | "Pcmoveil" | "Pcmoveuil" -> Cmoved | "Plb" -> Lbs | "Plbu" -> Lbz diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 01985060..2618983b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -91,8 +91,14 @@ Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := end. (** Ternary operator *) -Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := - (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). +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)) + | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => + (Eop (Osellimm cond0 imm) (e1 ::: 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( diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 4047048c..39ad763e 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1451,12 +1451,10 @@ Lemma eval_select0: /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. Proof. intros. - econstructor; split. - { - unfold select0. - repeat (try econstructor; try eassumption). - } - constructor. + unfold select0. + destruct (select0_match ty cond0 a1 a2 ac). + all: InvEval; econstructor; split; + repeat (try econstructor; try eassumption). Qed. Lemma bool_cond0_ne: @@ -1578,12 +1576,11 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - TrivialExists. - repeat (try econstructor; try eassumption). + erewrite <- (bool_cond0_ne (Some b)). + eapply eval_select0; repeat (try econstructor; try eassumption). + rewrite <- HeC. simpl. - f_equal. - rewrite HeC. - destruct b; simpl; reflexivity. + reflexivity. Qed. (* floating-point division *) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index daceab8b..439138da 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -265,8 +265,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (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::v2::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) - | Osellimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) + | 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. -- cgit From b5352b040da8c38b371316d67c2180dbab758295 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 23:16:35 +0200 Subject: move with immediates --- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 28 +++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2618983b..3df0c682 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -95,8 +95,12 @@ 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. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 39ad763e..21a06857 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1441,6 +1441,31 @@ Proof. 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 -> @@ -1454,7 +1479,8 @@ Proof. unfold select0. destruct (select0_match ty cond0 a1 a2 ac). all: InvEval; econstructor; split; - repeat (try econstructor; try eassumption). + try repeat (try econstructor; try eassumption). + all: rewrite eval_neg_condition0; rewrite select_neg; constructor. Qed. Lemma bool_cond0_ne: -- cgit From 72288298ea871d30db6693a65fe0ac2236a045c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Jun 2019 09:45:07 +0200 Subject: fixed reservation table for cmove --- mppa_k1c/PostpassSchedulingOracle.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 6ccc4e97..3924000b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -607,10 +607,14 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_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 -- cgit From 45844ce2210b58ddc29a2bcd55e3e0ddbe208ed0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Jun 2019 14:14:36 +0200 Subject: Fix for #134 Pjumptable not recognized --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3924000b..2fc561ee 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -291,7 +291,7 @@ let ctl_flow_rec = function | 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} + | 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 -- cgit From 8f88967df89f625d1a15f4c36f49450fe42e97db Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 8 Jun 2019 22:09:55 +0200 Subject: abstract_bb: few improvements while writing the paper --- mppa_k1c/abstractbb/ImpSimuTest.v | 236 ++++++++++++------ mppa_k1c/abstractbb/Impure/ImpHCons.v | 18 +- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 6 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 8 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 2 +- mppa_k1c/abstractbb/SeqSimuTheory.v | 275 +++++++++------------ 6 files changed, 294 insertions(+), 251 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 8f6b05b7..ea55b735 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -44,7 +44,32 @@ End ISeqLanguage. Module Type ImpDict. -Include 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 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. @@ -95,9 +120,10 @@ Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuI Module CoreL:=L. -Module ST := SimuTheory L Dict. +Module ST := SimuTheory L. Import ST. +Import Terms. Definition term_set_hid (t: term) (hid: hashcode): term := match t with @@ -212,9 +238,14 @@ Hint Resolve hLTcons_correct: wlp. (* Second, we use these hashed constructors ! *) -Record hsmem:= {hpre: list term; hpost: Dict.t term}. +Record hsmem:= {hpre: list term; hpost:> Dict.t term}. -Coercion hpost: hsmem >-> Dict.t. +(** 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 @@ -223,9 +254,9 @@ Definition hsmem_get (d:hsmem) x: ?? term := end. Lemma hsmem_get_correct (d:hsmem) x: - WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = smem_eval ge d x m. + 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, smem_eval, smem_get; destruct (Dict.get d x); wlp_simplify. + unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify. Qed. Global Opaque hsmem_get. Hint Resolve hsmem_get_correct: wlp. @@ -234,17 +265,17 @@ 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 -> smem_eval ge hd x m = (smem_eval ge d x 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 -> smem_eval ge hd x m <> None. + 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 -> smem_eval ge hd x m <> None. + 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. @@ -256,14 +287,14 @@ Definition naive_set (hd:hsmem) x (t:term) := 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 = term_eval ge t m) -> + (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, smem_eval ge d x m <> None). { 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. @@ -272,7 +303,7 @@ Proof. intros X1; exploit smem_valid_set_decompose_2; eauto. rewrite <- EQT; eauto. + exploit smem_valid_set_decompose_1; eauto. - - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. + - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. Local Hint Resolve smem_valid_set_decompose_1. intros; case (R.eq_dec x x0). + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. @@ -282,7 +313,7 @@ Local Hint Resolve naive_set_correct. 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 -> smem_eval ge hd1 x m = smem_eval ge hd2 x 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. @@ -363,11 +394,9 @@ Global Opaque hterm_append. Definition smart_set (hd:hsmem) x (ht:term) := match ht with - | Input _ _ => - DO ot <~ hsmem_get hd x;; - DO b <~ phys_eq ot ht;; - if b then - RET (hd.(hpost)) + | 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) @@ -379,12 +408,12 @@ Definition smart_set (hd:hsmem) x (ht:term) := Lemma smart_set_correct hd x ht: WHEN smart_set hd x ht ~> d THEN - forall ge m y, smem_eval ge d y m = smem_eval ge (Dict.set hd x ht) y m. + 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 smem_eval at 2; unfold smem_get; simpl; case (R.eq_dec x y). - - intros; subst. rewrite Dict.set_spec_eq. congruence. - - intros; rewrite Dict.set_spec_diff; auto. + 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. @@ -400,7 +429,7 @@ Definition hsmem_set (hd:hsmem) x (t:term) := 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 = term_eval ge t m) -> + (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. @@ -414,9 +443,9 @@ Proof. - intros m x0 ALLVALID; rewrite SMART. destruct (term_eval ge ht m) eqn: Hht. * case (R.eq_dec x x0). - + intros; subst. unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. + + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq. erewrite LIFT, EFFECT; eauto. - + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. + + 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. @@ -439,53 +468,53 @@ Qed. Local Hint Resolve exp_hterm_correct: wlp. *) -Fixpoint hexp_term (e: exp) (d od: hsmem): ?? term := +Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term := match e with - | PReg x => hsmem_get d x + | PReg x => hsmem_get hd x | Op o le => - DO lt <~ hlist_exp_term le d od;; + DO lt <~ list_exp_hterm le hd hod;; hApp o lt - | Old e => hexp_term e od od + | Old e => exp_hterm e hod hod end -with hlist_exp_term (le: list_exp) (d od: hsmem): ?? list_term := +with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term := match le with | Enil => hLTnil tt | Econs e le' => - DO t <~ hexp_term e d od;; - DO lt <~ hlist_exp_term le' d od;; + DO t <~ exp_hterm e hd hod;; + DO lt <~ list_exp_hterm le' hd hod;; hLTcons t lt - | LOld le => hlist_exp_term le od od + | LOld le => list_exp_hterm le hod hod end. -Lemma hexp_term_correct_x ge e hod od: +Lemma exp_hterm_correct_x ge e hod od: smem_model ge od hod -> forall hd d, smem_model ge d hd -> - WHEN hexp_term e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = term_eval ge (exp_term e d od) m. + 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 hlist_exp_term le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = list_term_eval ge (list_exp_term le d od) m); - unfold smem_model, smem_eval in * |- * ; simpl; wlp_simplify. + 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 hexp_term. +Global Opaque exp_hterm. -Lemma hexp_term_correct e hd hod: - WHEN hexp_term 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 = term_eval ge (exp_term e d od) m. +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 hexp_term_correct_x; eauto. + unfold wlp; intros; eapply exp_hterm_correct_x; eauto. Qed. -Hint Resolve hexp_term_correct: wlp. +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 <~ hexp_term e hd hod;; + DO ht <~ exp_hterm e hd hod;; DO nd <~ hsmem_set hd x ht;; hinst_smem i' nd hod end. @@ -503,37 +532,41 @@ Local Hint Resolve hinst_smem_correct: wlp. (* logging info: we log the number of inst-instructions passed ! *) Variable log_new_inst: unit -> ?? unit. -Fixpoint hbblock_smem_rec (p: bblock) (d: hsmem): ?? hsmem := +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;; - hbblock_smem_rec p' d' + bblock_hsmem_rec p' d' end. -Lemma hbblock_smem_rec_correct p: forall hd, - WHEN hbblock_smem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. +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 hbblock_smem_rec. -Local Hint Resolve hbblock_smem_rec_correct: wlp. +Global Opaque bblock_hsmem_rec. +Local Hint Resolve bblock_hsmem_rec_correct: wlp. +Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}. -Definition hbblock_smem: bblock -> ?? hsmem - := fun p => hbblock_smem_rec p {| 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. -Transparent allvalid. +Definition bblock_hsmem: bblock -> ?? hsmem + := fun p => bblock_hsmem_rec p hsmem_empty. -Lemma hbblock_smem_correct p: - WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Lemma bblock_hsmem_correct p: + WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. - unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, smem_valid, smem_eval, smem_get; simpl; intuition; - rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. + Local Hint Resolve hsmem_empty_correct. + wlp_simplify. Qed. -Global Opaque hbblock_smem. +Global Opaque bblock_hsmem. End CanonBuilding. @@ -586,13 +619,13 @@ Qed. Global Opaque list_term_hash_eq. Hint Resolve list_term_hash_eq_correct: wlp. -Lemma smem_eval_intro (d1 d2: hsmem): - (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, smem_eval ge d1 x m = smem_eval ge d2 x m). +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 smem_eval, smem_get; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. + unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. Qed. -Local Hint Resolve hbblock_smem_correct Dict.eq_test_correct: wlp. +Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp. Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := {| @@ -629,9 +662,9 @@ Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := DO failure_in_failpreserv <~ make_cref false;; DO r <~ (TRY - DO d1 <~ hbblock_smem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; + 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 <~ hbblock_smem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; + 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 ( @@ -653,12 +686,12 @@ Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := 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. + apply bblock_smem_simu; auto. split. + intros m; rewrite <- EQPRE1, <- EQPRE2. rewrite ! allvalid_extensionality. unfold incl in * |- *; intuition eauto. - + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. - erewrite smem_eval_intro; 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 * |- *. @@ -677,8 +710,8 @@ End Prog_Eq_Gen. -Definition hht: hashH term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. -Definition hlht: hashH list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. +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 @@ -746,8 +779,8 @@ Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv. Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := DO log <~ count_logger ();; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + 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)) @@ -996,8 +1029,8 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + 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)) @@ -1017,8 +1050,8 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + 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 !! *) @@ -1074,9 +1107,60 @@ End ImpSimu. Require Import FMapPositive. + +Require Import PArith. +Require Import FMapPositive. + Module ImpPosDict <: ImpDict with Module R:=Pos. -Include PosDict. +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 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 := diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index 637e8296..d8002375 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -110,17 +110,17 @@ Module HConsing. Export HConsingDefs. (* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) -Axiom xhCons: forall {A}, (hashH A) -> ?? hashConsing A. +Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A. Extract Constant xhCons => "ImpHConsOracles.xhCons". Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". -Definition hCons {A} (hh: hashH A): ?? (hashConsing A) := - DO hco <~ xhCons hh ;; +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 hh x.(hdata) x' ;; + DO b0 <~ hash_eq hp x.(hdata) x' ;; assert_b b0 hCons_eq_msg;; RET x'); next_hid := hco.(next_hid); @@ -130,10 +130,10 @@ Definition hCons {A} (hh: hashH A): ?? (hashConsing A) := |}. -Lemma hCons_correct A (hh: hashH A): - WHEN hCons hh ~> hco THEN - (forall x y, WHEN hh.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hh x)=(ignore_hid hh y)) -> - forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hh x.(hdata)=ignore_hid hh 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. @@ -149,7 +149,7 @@ Record hashV {A:Type}:= { }. Arguments hashV: clear implicits. -Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashH (hashV A) := {| +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 |} diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 477be65c..de4c7973 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -130,17 +130,17 @@ Record hashinfo {A: Type} := { Arguments hashinfo: clear implicits. (* for inductive types with intrinsic hash-consing *) -Record hashH {A:Type}:= { +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 hashH: clear implicits. +Arguments hashP: clear implicits. Axiom unknown_hid: hashcode. Extract Constant unknown_hid => "-1". -Definition ignore_hid {A} (hh: hashH A) (hv:A) := set_hid hh hv unknown_hid. +Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid. Record hashExport {A:Type}:= { get_info: hashcode -> ?? hashinfo A; diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml index 3994cae6..2b66899b 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -17,13 +17,13 @@ let make_dict (type key) (p: key Dict.hash_params) = exception Stop;; -let xhCons (type a) (hh:a hashH) = +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 hashinfo - let equal x y = hh.hash_eq x.hdata y.hdata + 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 @@ -42,7 +42,7 @@ let xhCons (type a) (hh:a hashH) = match MyHashtbl.find_opt t k with | Some d -> d | None -> (*print_string "+";*) - let d = hh.set_hid k.hdata (MyHashtbl.length t) in + 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); @@ -58,7 +58,7 @@ let xhCons (type a) (hh:a hashH) = | (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.(hh.get_hid d) <- k) t; + MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t; { 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 9f5eca89..5075d176 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -2,4 +2,4 @@ open ImpPrelude open HConsingDefs val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t -val xhCons: 'a hashH -> 'a hashConsing +val xhCons: 'a hashP -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 8b6a372a..649dd083 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -3,104 +3,90 @@ *) +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 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. - - -Module SimuTheory (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). +Module SimuTheory (L: SeqLanguage). Export L. Export LP. -Export Terms. + +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: Dict.t term}. - -Coercion post: smem >-> Dict.t. +Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}. (** initial symbolic memory *) -Definition smem_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. +Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}. -Definition smem_get (d:Dict.t term) x := - match Dict.get d x with - | None => Input x unknown_hid - | Some t => t - end. - -Fixpoint exp_term (e: exp) (d old: Dict.t term): term := +Fixpoint exp_term (e: exp) (d old: smem) : term := match e with - | PReg x => smem_get d x - | Op o le => App o (list_exp_term le d old) unknown_hid + | 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: Dict.t term) : list_term := +with list_exp_term (le: list_exp) (d old: smem) : list_term := match le with - | Enil => LTnil unknown_hid - | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) unknown_hid + | 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. -(** evaluation of the post-condition *) -Definition smem_eval ge (d: Dict.t term) x (m:mem) := - term_eval ge (smem_get d x) m. (** assignment of the symbolic memory *) Definition smem_set (d:smem) x (t:term) := - {| pre:=(fun ge m => (smem_eval ge d x m) <> None /\ (d.(pre) ge m)); - post:=Dict.set d x t |}. + {| 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: - smem_eval ge (smem_set d x t) x m = term_eval ge t m. + term_eval ge (smem_set d x t x) m = term_eval ge t m. Proof. - unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. + unfold smem_set; simpl; case (R.eq_dec x x); try congruence. Qed. Lemma set_spec_diff d x y t m: - x <> y -> smem_eval ge (smem_set d x t) y m = smem_eval ge d y m. + x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m. Proof. - intros; unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. + unfold smem_set; simpl; case (R.eq_dec x y); try congruence. Qed. -Lemma smem_eval_empty x m: smem_eval ge smem_empty x m = Some (m x). -Proof. - unfold smem_eval, smem_get; rewrite Dict.empty_spec; simpl; auto. -Qed. - -Hint Rewrite set_spec_eq smem_eval_empty: dict_rw. - Fixpoint inst_smem (i: inst) (d old: smem): smem := match i with | nil => d @@ -116,8 +102,9 @@ Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := let d':=inst_smem i d d in bblock_smem_rec p' d' end. - +(* Local Hint Resolve smem_eval_empty. +*) Definition bblock_smem: bblock -> smem := fun p => bblock_smem_rec p smem_empty. @@ -140,37 +127,36 @@ Qed. Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic. Lemma term_eval_exp e (od:smem) m0 old: - (forall x, smem_eval ge od x m0 = Some (old x)) -> - forall d m1, - (forall x, smem_eval ge (d:smem) x m0 = Some (m1 x)) -> + (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. - unfold smem_eval in * |- *; intro H. + intro H. induction e using exp_mut with - (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (smem_get d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); + (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, +Lemma inst_smem_abort i m0 x old: forall (d:smem), pre (inst_smem i d old) ge m0 -> - smem_eval ge d x m0 = None -> - smem_eval ge (inst_smem i d old) x m0 = None. + 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. - destruct (R.eq_dec x y). - * subst; autorewrite with dict_rw. - generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. - unfold smem_set; simpl; intuition congruence. - * rewrite set_spec_diff; auto. + 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 -> - smem_eval ge d x m0 = None -> - smem_eval ge (bblock_smem_rec p d) x m0 = None. + 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. @@ -178,11 +164,11 @@ Proof. Qed. Lemma inst_smem_Some_correct1 i m0 old (od:smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (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, smem_eval ge d x m0 = Some (m1 x)) -> - forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x). + (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. @@ -190,16 +176,14 @@ Proof. 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 term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + 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, smem_eval ge d x m0 = Some (m1 x)) -> - forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x). + (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. induction p as [ | i p]; simpl; intros m1 m2 d H. @@ -212,39 +196,37 @@ Qed. Lemma bblock_smem_Some_correct1 p m0 m1: run ge p m0 = Some m1 - -> forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x). + -> 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, smem_eval ge od x m0 = Some (old x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> forall m1 d, pre (inst_smem i d od) ge m0 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - inst_run ge i m1 old = None -> exists x, smem_eval ge (inst_smem i d od) x m0 = None. + (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; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + 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. - autorewrite with dict_rw. + rewrite set_spec_eq. erewrite term_eval_exp; eauto. Qed. Lemma inst_smem_Some_correct2 i m0 old (od: smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (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, smem_eval ge d x m0 = Some (m1 x)) -> - (forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x)) -> + (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. @@ -255,20 +237,18 @@ Proof. - 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 term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + 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. - autorewrite with dict_rw. + 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, smem_eval ge d x m0 = Some (m1 x)) -> - (forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x)) -> + (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. @@ -278,7 +258,7 @@ Proof. - intros H. destruct (inst_run ge i m1 m1) eqn: Heqom. + refine (IHp _ _ _ _ _ _); eauto. - + assert (X: exists x, term_eval ge (smem_get (inst_smem i d d) x) m0 = None). + + 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). @@ -286,21 +266,20 @@ Proof. congruence. Qed. - Lemma bblock_smem_Some_correct2 p m0 m1: pre (bblock_smem p) ge m0 -> - (forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x)) + (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, smem_eval ge od x m0 = Some (old x)) -> + (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, smem_eval ge d x m0 = Some (m1 x)) -> + (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. @@ -309,17 +288,15 @@ Proof. eapply IHi; eauto. + unfold smem_set in * |- *; simpl. rewrite Hm1; intuition congruence. - + intros x0. unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + + 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, smem_eval ge d x m0 = Some (m1 x)) -> + (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. @@ -337,22 +314,26 @@ Proof. unfold smem_empty; simpl. auto. Qed. -Definition smem_valid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. +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: - (forall m, smem_valid ge (bblock_smem p1) m -> smem_valid ge (bblock_smem p2) m) -> - (forall m0 x m1, smem_valid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> - smem_eval ge (bblock_smem p2) x m0 = Some m1) -> + smem_simu (bblock_smem p1) (bblock_smem p2) -> bblock_simu ge p1 p2. Proof. Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. - unfold smem_valid; intros INCL EQUIV m DONTFAIL. + 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, smem_eval ge (bblock_smem p1) x m = Some (m1 x)); eauto. + 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; apply EQUIV; intuition eauto. + + intro x; erewrite <- EQUIV; intuition eauto. congruence. Qed. @@ -370,7 +351,7 @@ 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); autorewrite with dict_rw. + generalize (VALID x); rewrite set_spec_eq. tauto. Qed. @@ -379,50 +360,28 @@ Lemma smem_valid_set_proof d x t m: Proof. unfold smem_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. + + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto. Qed. -End SIMU_THEORY. - -End SimuTheory. - -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. +End SIMU_THEORY. -Definition empty {A}: t A := PositiveMap.empty A. +(** 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 empty_spec A x: - get (empty (A:=A)) x = None. +Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m). Proof. - unfold get, empty; apply PositiveMap.gempty; auto. + 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 PosDict. \ No newline at end of file +End SimuTheory. -- cgit From 69f4580c239548082d899b3719b5de2d686252c3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 12 Jun 2019 17:05:55 +0200 Subject: Removing the Admitted warning when running "make check-admitted" --- mppa_k1c/ExtValues.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 8e6aa028..3370fae3 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -424,7 +424,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, -- cgit From 60f5b79492144740338e5d77653c4dc3e61606e7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 14 Jun 2019 17:46:11 +0200 Subject: [BROKEN] Replaced the accesses lists by Maps, does not compile --- mppa_k1c/PostpassSchedulingOracle.ml | 66 +++++++++++++++++++++++++++++++----- 1 file changed, 58 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2fc561ee..c153576b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -699,20 +699,56 @@ 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 OrderedLoc : Map.OrderedType = struct + type t = location + let compare l l' = compare (loc2int l) (loc2int l') +end + +module LocMap = Map.Make(OrderedLoc) 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 rec list2locmap v = function + | [] -> LocMap.empty + | loc :: l -> LocMap.add loc v (list2locmap v l) + +let get_accesses locs locmap = List.map (fun l _ -> List.mem l locs) locmap + +let latency_constraints bb = + let written = ref LocMap.empty + and read = ref LocMap.empty + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: inst_info) = + let write_accesses = list2locmap !count i.write_locs + and read_accesses = list2locmap !count 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 begin + Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + Map.iter (fun l 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 := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; + read := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) + +(* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] and read = ref [] and count = ref 0 @@ -734,6 +770,7 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" count := !count + 1 end in (List.iter step instr_infos; !constraints) +*) (** * Using the InstructionScheduler @@ -829,7 +866,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -let do_schedule bb = +let real_do_schedule bb = let problem = build_problem bb in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then validated_scheduler cascaded_scheduler @@ -850,6 +887,19 @@ let do_schedule bb = end; bundles) +let do_schedule bb = + let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb + in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime) + in let sched = real_do_schedule bb + in let refer = ref sched + in begin + for i = 1 to 100-1 do + refer := (if i > 0 then real_do_schedule bb else real_do_schedule bb); + done; + Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time); + sched + end + (** * Dumb schedule if the above doesn't work *) -- cgit From 8697837760ad3b0002ed94ff3e83a60a15c259a1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 14:31:37 +0200 Subject: [NOT TESTED] ça compile MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingOracle.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c153576b..9912fbcb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,7 +707,7 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module OrderedLoc : Map.OrderedType = struct +module OrderedLoc = struct type t = location let compare l l' = compare (loc2int l) (loc2int l') end @@ -723,7 +723,7 @@ let rec list2locmap v = function | [] -> LocMap.empty | loc :: l -> LocMap.add loc v (list2locmap v l) -let get_accesses locs locmap = List.map (fun l _ -> List.mem l locs) locmap +let get_accesses locs locmap = LocMap.filter (fun l _ -> List.mem l locs) locmap let latency_constraints bb = let written = ref LocMap.empty @@ -738,12 +738,12 @@ let latency_constraints bb = and waw = get_accesses i.write_locs !written and war = get_accesses i.write_locs !read in begin - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; + LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + LocMap.iter (fun l 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 := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; - read := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; + written := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; + read := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; count := !count + 1 end in (List.iter step instr_infos; !constraints) -- cgit From 45e8a0997169b0b081f3cea500debc237e4a8c76 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 18:43:14 +0200 Subject: [BROKEN] Fixed the dependency oracle, does not compile I was removing too many dependencies --- mppa_k1c/PostpassSchedulingOracle.ml | 50 ++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9912fbcb..75dc2495 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,26 +707,59 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module OrderedLoc = struct - type t = location - let compare l l' = compare (loc2int l) (loc2int l') +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 LocMap = Map.Make(OrderedLoc) +module LocHash = Hashtbl.Make(HashedLoc) + +(* 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)) +(* Returns a list of instruction ids *) +let rec get_accesses hashloc = function + | [] -> [] + | loc :: llocs -> (LocHash.find hashloc loc) @ (get_accesses hashloc llocs) + +let latency_constraints bb = + let written = LocHash.create 0 + and read = LocHash.create 0 + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: inst_info) = + 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 begin + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !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); + (* 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 (LocHash.find read loc)) i.read_locs; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) + +(* let rec list2locmap v = function | [] -> LocMap.empty | loc :: l -> LocMap.add loc v (list2locmap v l) -let get_accesses locs locmap = LocMap.filter (fun l _ -> List.mem l locs) locmap - -let latency_constraints bb = - let written = ref LocMap.empty + let written = ref (LocHash.create 0) and read = ref LocMap.empty and count = ref 0 and constraints = ref [] @@ -747,6 +780,7 @@ let latency_constraints bb = count := !count + 1 end in (List.iter step instr_infos; !constraints) + *) (* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] -- cgit From 99cf129352db347291e893d1102df9804fd04472 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 18:53:12 +0200 Subject: [BROKEN] still broken, just fixing a logical detail --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 75dc2495..09d5e15b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -749,7 +749,7 @@ let latency_constraints bb = 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 (LocHash.find read loc)) i.read_locs; + List.iter (fun loc -> LocHash.replace read loc ((!count) :: (LocHash.find read loc))) i.read_locs; count := !count + 1 end in (List.iter step instr_infos; !constraints) -- cgit From b480d21954b63abb93411e7691e4cafc9d658f3f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 18 Jun 2019 16:02:40 +0200 Subject: [NOT TESTED] Compiles and should work ? --- mppa_k1c/PostpassSchedulingOracle.ml | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 09d5e15b..b54dfeda 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,14 +707,15 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module HashedLoc = struct +(* 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 +end *) -module LocHash = Hashtbl.Make(HashedLoc) +(* module LocHash = Hashtbl.Make(HashedLoc) *) +module LocHash = Hashtbl (* Hash table : location => list of instruction ids *) @@ -723,21 +724,26 @@ let rec intlist n = else if n = 0 then [] else (n-1) :: (intlist (n-1)) +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 = function +let rec get_accesses hashloc (ll: location list) = match ll with | [] -> [] - | loc :: llocs -> (LocHash.find hashloc loc) @ (get_accesses hashloc llocs) + | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) let latency_constraints bb = - let written = LocHash.create 0 - and read = LocHash.create 0 + 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 raw = get_accesses i.read_locs written - and waw = get_accesses i.write_locs written - and war = get_accesses i.write_locs read + 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 i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; @@ -749,7 +755,7 @@ let latency_constraints bb = 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) :: (LocHash.find read loc))) i.read_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) -- cgit From 82db72dbd06eced8f72ca4a41e08892b908b5036 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 18 Jun 2019 16:08:25 +0200 Subject: Reverting the unwanted time measurement from the other branch --- mppa_k1c/PostpassSchedulingOracle.ml | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b54dfeda..462e9cd0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -906,7 +906,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -let real_do_schedule bb = +let do_schedule bb = let problem = build_problem bb in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then validated_scheduler cascaded_scheduler @@ -927,19 +927,6 @@ let real_do_schedule bb = end; bundles) -let do_schedule bb = - let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb - in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime) - in let sched = real_do_schedule bb - in let refer = ref sched - in begin - for i = 1 to 100-1 do - refer := (if i > 0 then real_do_schedule bb else real_do_schedule bb); - done; - Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time); - sched - end - (** * Dumb schedule if the above doesn't work *) -- cgit From 0ad6bc290c564ccaffd7df0e7232e133b94895f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 19 Jun 2019 14:39:18 +0200 Subject: pretty print statistics --- mppa_k1c/InstructionScheduler.ml | 69 +++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 1fa55c9b..2836c160 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,7 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(** FIXME - warning fix *) +(* FIXME DUMMY CODE to placate warnings + *) let _ = priority_list_scheduler INSTRUCTION_ORDER;; type bundle = int list;; @@ -367,7 +368,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 @@ -426,6 +427,7 @@ let max_scheduled_time solution = done; !time;; +(* DM: I think this is buggy *) let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with @@ -1107,17 +1109,6 @@ let ilp_print_problem channel problem pb_type = mapper_final_predecessors = predecessors.(nr_instructions) };; -(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) - -let positive_float_round x = truncate (x +. 0.5) - -let float_round (x : float) : int = - if x > 0.0 - then positive_float_round x - else - (positive_float_round (-. x)) - -let rounded_int_of_string x = float_round (float_of_string x) - let ilp_read_solution mapper channel = let times = Array.make (match mapper.mapper_pb_type with @@ -1143,7 +1134,7 @@ 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)) + try int_of_string (String.sub line (space+1) ((String.length line)-space-1)) with Failure _ -> failwith "bad ilp output: not a time number" in @@ -1162,22 +1153,15 @@ let ilp_read_solution mapper channel = times;; 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 filename_in = "problem.lp" + and filename_out = "problem.sol" 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 +1174,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;; -- cgit From 80295d3c7cc82c34903f7ed92a77a64870f1920f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 21 Jun 2019 22:07:28 +0200 Subject: -frevlist --- mppa_k1c/InstructionScheduler.ml | 41 +++++++++++++++++++++++++++++------- mppa_k1c/PostpassSchedulingOracle.ml | 2 ++ 2 files changed, 35 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 2836c160..b9e362c7 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -427,7 +427,15 @@ let max_scheduled_time solution = done; !time;; -(* DM: I think this is buggy *) +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;; + +(* Does not take into account latencies to exit point *) let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with @@ -435,11 +443,13 @@ let schedule_reversed (scheduler : problem -> solution option) | Some solution -> let nr_instructions = get_nr_instructions problem and maxi = max_scheduled_time solution in - Some (Array.init (Array.length solution) + let ret = Array.init (Array.length solution) (fun i -> if i < nr_instructions then maxi-solution.(nr_instructions-1-i) - else solution.(i)));; + else solution.(i)) in + ret.(nr_instructions) <- recompute_makespan problem ret; + Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) let reverse_list_scheduler = schedule_reversed list_scheduler;; @@ -1109,6 +1119,17 @@ let ilp_print_problem channel problem pb_type = mapper_final_predecessors = predecessors.(nr_instructions) };; +(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) + +let positive_float_round x = truncate (x +. 0.5) + +let float_round (x : float) : int = + if x > 0.0 + then positive_float_round x + else - (positive_float_round (-. x)) + +let rounded_int_of_string x = float_round (float_of_string x) + let ilp_read_solution mapper channel = let times = Array.make (match mapper.mapper_pb_type with @@ -1134,9 +1155,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 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"); @@ -1153,11 +1175,14 @@ let ilp_read_solution mapper channel = times;; let ilp_solver = ref "ilp_solver" - + +let problem_nr = ref 0 + let ilp_scheduler pb_type problem = try - let filename_in = "problem.lp" - and filename_out = "problem.sol" in + 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 opb_problem = open_out filename_in in let mapper = ilp_print_problem opb_problem problem pb_type in close_out opb_problem; diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 462e9cd0..19eec3e6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -912,6 +912,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 -- cgit From 5be8f955647e5becc5f53b04da2b1c408b6cd277 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 22 Jun 2019 10:09:13 +0200 Subject: schedule from end --- mppa_k1c/InstructionScheduler.ml | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index b9e362c7..c64628ff 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -390,32 +390,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 };; @@ -427,6 +431,7 @@ 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 -> @@ -434,21 +439,17 @@ let recompute_makespan problem solution = then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) ) problem.latency_constraints; !ms;; + *) -(* Does not take into account latencies to exit point *) 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 - let ret = Array.init (Array.length solution) - (fun i -> - if i < nr_instructions - then maxi-solution.(nr_instructions-1-i) - else solution.(i)) in - ret.(nr_instructions) <- recompute_makespan problem ret; + 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 Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) -- cgit From 6419d31749d57b4528b2f5f1e54336a141e4e169 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 22 Jun 2019 11:57:06 +0200 Subject: fix makespan computation --- mppa_k1c/InstructionScheduler.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index c64628ff..e182804b 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -449,7 +449,9 @@ let schedule_reversed (scheduler : problem -> solution option) 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 + (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. *) -- cgit From 44d3868140325950144c16ef7d51423f7f1cbd20 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 23 Jun 2019 19:39:43 +0200 Subject: maj forward_simu_par_wio_bblock_aux en forward_simu_par_wio avec une legere simplification (comme dans le papier) --- mppa_k1c/Asmblockdeps.v | 22 ++++++++++------------ mppa_k1c/Asmvliw.v | 18 +++++++++--------- 2 files changed, 19 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b11a77ff..a8f81be6 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1081,14 +1081,13 @@ 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 forward_simu_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 (forward_simu_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. @@ -1098,20 +1097,19 @@ Proof. - 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 forward_simu_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 (forward_simu_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. @@ -1157,7 +1155,7 @@ 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 (forward_simu_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. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index bb6b7132..c5b7db45 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -148,7 +148,7 @@ 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. @@ -1553,16 +1553,16 @@ Definition incrPC size_b (rs: regset) := Definition parexec_exit (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 => parexec_exit 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. @@ -1689,7 +1689,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: @@ -1699,7 +1699,7 @@ 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. @@ -1777,9 +1777,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]. -- cgit From 2cad56ee1f3d508d1671628a10da1852c5ee95a7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Jun 2019 11:49:37 +0200 Subject: pretty-printing for extra operations (unfinished) --- mppa_k1c/PrintOp.ml | 39 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 4b833014..8417571a 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,6 +59,19 @@ let print_condition reg pp = function | _ -> fprintf pp "" +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 = function | Omove, [r1] -> reg pp r1 | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) @@ -154,6 +168,29 @@ let print_operation reg pp = function | 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) + | 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) + | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 + | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) + | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "" let print_addressing reg pp = function -- cgit From 0372e87d41994a24cf001eba00a5797f80192c29 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Jun 2019 12:15:45 +0200 Subject: op printing (still incomplete) --- mppa_k1c/PrintOp.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 8417571a..575fa94f 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -168,6 +168,7 @@ let print_operation reg pp = function | 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) + | 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 @@ -184,14 +185,24 @@ let print_operation reg pp = function print_condition0 reg pp cond0 rc; fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) | 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) | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "" + | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) + | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) + | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 + | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 + | (Omaddimm imm), [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) + | (Omaddlimm imm), [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) + | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 + | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 + | _, _ -> fprintf pp "" let print_addressing reg pp = function | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) -- cgit From d0d234e3a8b195519f60f224b40cf74c6a7691d7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 9 Jul 2019 17:57:22 +0200 Subject: Replaced the solution -> bundles part by an algorithm hopefully linear --- mppa_k1c/PostpassSchedulingOracle.ml | 93 +++++++++++++++--------------------- 1 file changed, 39 insertions(+), 54 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 19eec3e6..0eff8788 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -760,58 +760,6 @@ let latency_constraints bb = end in (List.iter step instr_infos; !constraints) -(* -let rec list2locmap v = function - | [] -> LocMap.empty - | loc :: l -> LocMap.add loc v (list2locmap v l) - - let written = ref (LocHash.create 0) - and read = ref LocMap.empty - and count = ref 0 - and constraints = ref [] - and instr_infos = instruction_infos bb - in let step (i: inst_info) = - let write_accesses = list2locmap !count i.write_locs - and read_accesses = list2locmap !count 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 begin - LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; - LocMap.iter (fun l 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 := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; - read := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; - count := !count + 1 - end - in (List.iter step instr_infos; !constraints) - *) - -(* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) - let written = ref [] - and read = ref [] - 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 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 *) - 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; - count := !count + 1 - end - in (List.iter step instr_infos; !constraints) -*) - (** * Using the InstructionScheduler *) @@ -880,15 +828,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 | [] -> [] -- cgit From d65ab077e80d924bd6f23b36675c9f86f97a1b98 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 17 Jul 2019 16:23:34 +0200 Subject: (#107) Rename "forward_simu" into "bisimu" --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a8f81be6..9855afa2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -842,7 +842,7 @@ 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 -> @@ -994,7 +994,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 -> @@ -1003,13 +1003,13 @@ 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. + exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. destruct (parexec_basic_instr _ _ _ _ _ _); 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 -> @@ -1067,37 +1067,37 @@ 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). Proof. intros; unfold parexec_exit. - exploit (forward_simu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. + 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 ge fn rsr mr sr 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_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. unfold parexec_wio, trans_block_aux. - exploit (forward_simu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. + 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 mr sr 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_outcome @@ -1108,11 +1108,11 @@ Theorem forward_simu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). Proof. intros. - exploit (forward_simu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. + 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. @@ -1143,7 +1143,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 -> @@ -1155,7 +1155,7 @@ 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 m1 s1' 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. @@ -1163,16 +1163,16 @@ Proof. Qed. (* sequential execution *) -Theorem forward_simu_basic ge fn bi rs m s: +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 -> @@ -1180,33 +1180,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. @@ -1243,10 +1243,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'. @@ -1280,8 +1280,8 @@ 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. -- cgit From 2ed659b796c97de9d2854e73dfe3e803a92a67da Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:24:20 +0200 Subject: Typo in Prevsubxw --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8365d54f..674695d9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -540,7 +540,7 @@ module Target (*: TARGET*) = | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Prevsubxw (s14, rd, rs1, rs2) -> - fprintf oc " subx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + 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 -- cgit From d697fd077a83d572975c8305baa1f35edca9a05a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:25:21 +0200 Subject: (#137) Removed the useless strings in PostpassSchedulingOracle --- mppa_k1c/PostpassSchedulingOracle.ml | 591 +++++++++++++++-------------------- 1 file changed, 254 insertions(+), 337 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 0eff8788..af66bdb6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -15,208 +15,242 @@ 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 + | 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; 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" - | Paddxw _ -> "Paddxw" - | Psubw -> "Psubw" - | Prevsubxw _ -> "Psubxw" - | 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" - | Paddxl _ -> "Paddxl" - | Psubl -> "Psubl" - | Prevsubxl _ -> "Psubxl" - | 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" - | Paddxiw _ -> "Paddxiw" - | Prevsubiw -> "Psubiw" - | Prevsubxiw _ -> "Psubxiw" - | 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" - | Prevsubil -> "Psubil" - | Paddxil _ -> "Paddxil" - | Prevsubxil _ -> "Psubxil" - | 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" - | Pmsubw -> "Pmsubw" - | Pmsubl -> "Pmsubl" - | Pcmove _ -> "Pcmove" - | Pcmoveu _ -> "Pcmoveu" - -let arith_arri32_str = function - | Pmaddiw -> "Pmaddiw" - | Pcmoveiw _ -> "Pcmoveiw" - | Pcmoveuiw _ -> "Pcmoveuiw" - -let arith_arri64_str = function - | Pmaddil -> "Pmaddil" - | Pcmoveil _ -> "Pcmoveil" - | Pcmoveuil _ -> "Pcmoveuil" - -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 = arith_arri32_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } - -let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_str i; 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 + | 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 + +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 + | 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 } + +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 } + +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} + +let arith_arri32_rec i rd rs imm32 = { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } + +let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_real i; 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_real 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_real 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_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false} 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} let arith_rec i = match i with @@ -228,45 +262,45 @@ let arith_rec i = | 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 = []; + | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} + | 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} - | PArithRF64 (rd, f) -> { inst = arith_rf64_str; write_locs = [Reg (IR rd)]; read_locs = []; + | 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} | 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} + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} | 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} | 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} + { 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} | 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 = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} 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)) + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) ; 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)) + { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)) ; 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)) + { 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)) ; 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 + | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None ; 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 } -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 } let basic_rec i = match i with @@ -277,20 +311,20 @@ 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} 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} + | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} + | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} + | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} + | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} + | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} + | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} + | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} + | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} | 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 = @@ -473,139 +507,22 @@ let lsu_data_y : int array = let resmap = fun r -> match r with (** Real instructions *) -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 | 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 - | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz - | Fcompw | Fcompd - -let ab_inst_to_real = function - | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw - | "Paddxw" | "Paddxiw" -> Addxw - | "Paddxl" | "Paddxil" -> Addxd - | "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 - | "Pmsubw" | "Pmsubiw" -> Msbfw - | "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" | "Pmaddil" -> Maddd - | "Pmsubl" | "Pmsubil" -> Msbfd - | "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" | "Pcmoveiw" | "Pcmoveuiw" | "Pcmoveil" | "Pcmoveuil" -> 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 -> (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 -> (match encoding with None | Some U6 | Some S10 -> alu_tiny @@ -667,11 +584,11 @@ let rec_to_usage r = 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 + | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 @@ -686,7 +603,7 @@ let real_inst_to_latency = function 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 + and latency = real_inst_to_latency r.inst in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) -- cgit From c57baa03fa83d1295a3ba622986a02bd2fa6476f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:32:46 +0200 Subject: Removing a hidden FIXME that hopefully didn't have any impact.. --- mppa_k1c/PostpassSchedulingOracle.ml | 7 ------- 1 file changed, 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index af66bdb6..895f9f40 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -912,10 +912,3 @@ let schedule bb = (* print_problem (build_problem bb); *) if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb -(** FIXME - Fix for PostpassScheduling WIP *) - -type bblock' = int - -let trans_block bb = 1 - -let bblock_equivb' bb1 bb2 = true -- cgit From 4c379d48b35e7c8156f3953fede31d5e47faf8ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 19 Jul 2019 18:59:44 +0200 Subject: helpers broke compilation --- mppa_k1c/Archi.v | 36 ++++++++++++++++++++++++------------ mppa_k1c/Builtins1.v | 33 +++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 3 +++ 3 files changed, 60 insertions(+), 12 deletions(-) create mode 100644 mppa_k1c/Builtins1.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 113f5d51..800c9fe5 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for RISC-V *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -34,6 +34,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,26 +43,36 @@ Qed. We need to extend the [choose_binop_pl] functions to account for this case. *) -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +(* Always choose the first NaN argument, if any *) -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. -(* TODO check *) Definition fpu_returns_default_qNaN := false. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, z, y). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_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/Builtins1.v b/mppa_k1c/Builtins1.v new file mode 100644 index 00000000..f6e643d2 --- /dev/null +++ b/mppa_k1c/Builtins1.v @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3df0c682..688820b3 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -54,6 +54,7 @@ Require Import OpHelpers. Require Import ExtValues. Require Import DecBoolOps. Require Import Chunks. +Require Import Builtins. Require Compopts. Local Open Scope cminorsel_scope. @@ -673,6 +674,8 @@ Definition divfs_base (e1: expr) (e2: expr) := Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). End SELECT. +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. (* Local Variables: *) (* mode: coq *) (* End: *) \ No newline at end of file -- cgit From 780ad9d001af651a49d7470e963ed9a49ee11a4c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 19 Jul 2019 19:49:46 +0200 Subject: various fixes --- mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/CBuiltins.ml | 4 ++-- mppa_k1c/SelectOpproof.v | 15 +++++++++++++++ mppa_k1c/TargetPrinter.ml | 4 +++- 4 files changed, 22 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 65dee6c7..556fac9a 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -467,11 +467,11 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pdzerol addr) | "__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)); + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); emit (Pafaddw(addr, res)) | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> emit (Palclrd(res, addr)) diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 2f80c90f..09a9ba97 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 *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 21a06857..e009ed98 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. @@ -1629,4 +1631,17 @@ Proof. intros; unfold divfs_base. econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. + +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 674695d9..dafad7fb 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -140,6 +140,8 @@ 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" @@ -324,7 +326,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 -- cgit From 34c136fcd0ffcfe61e3cec5c72a90a1d3bcdc941 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 22 Jul 2019 18:38:49 +0200 Subject: (#137) [BROKEN] - Finer latencies for the oracle. Some debugging to do --- mppa_k1c/PostpassSchedulingOracle.ml | 133 ++++++++++++++++++++++++----------- 1 file changed, 93 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 895f9f40..b9fc3c18 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -38,6 +38,8 @@ type ab_inst_rec = { 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; } @@ -232,25 +234,40 @@ 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 } +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 } +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} +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 = { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } +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 = { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } +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} +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 = { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false} +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} +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 = loadsymbol_real; 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 @@ -262,45 +279,54 @@ let arith_rec i = | 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_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; 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} + 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} + 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_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} + { 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 = loadqrro_real; 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 = 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} + { 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 (i, rs1, rs2, rs3) | PLoadRRRXS (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} + { 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_real 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 = storeqrro_real; 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 = 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)) - ; is_control = false} - | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_real 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_real; 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_real; 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 @@ -311,20 +337,24 @@ let basic_rec i = | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs - | Pnop -> { inst = nop_real; 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 = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} - | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} - | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} - | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} - | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; 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 = @@ -350,6 +380,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; @@ -582,6 +614,16 @@ let rec_to_usage r = | Fnarrowdw -> alu_full | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 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 | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw @@ -601,10 +643,17 @@ let real_inst_to_latency = function | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 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 r.inst - in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } + 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) @@ -651,6 +700,8 @@ 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) = ifrom.latency + (inst_info_to_dlatency ito) + let latency_constraints bb = let written = LocHash.create 70 and read = LocHash.create 70 @@ -662,8 +713,10 @@ let latency_constraints bb = and waw = get_accesses written i.write_locs and war = get_accesses read i.write_locs in begin - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + 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); (* Updating "read" and "written" hashmaps *) -- cgit From 4c1209c5c1e0e667f20f13bc02662fdc7e4868ac Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 23 Jul 2019 10:42:47 +0200 Subject: (#137) Possible fix --- mppa_k1c/PostpassSchedulingOracle.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b9fc3c18..fd03a80c 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -700,7 +700,10 @@ 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) = ifrom.latency + (inst_info_to_dlatency ito) +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 -- cgit From 7da1af080217eef5626480ac30feda45ff8ca002 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Jul 2019 11:01:37 +0200 Subject: (#144) Fixing on RTL dumps --- mppa_k1c/Op.v | 20 ++++++++--------- mppa_k1c/PrintOp.ml | 63 ++++++++++++++++++++++++++++++++++------------------- 2 files changed, 50 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 35fbb596..815d3958 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -100,23 +100,23 @@ 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] *) @@ -158,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] *) diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 575fa94f..7c408cdf 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -72,7 +72,7 @@ let int_of_s14 = function | SHIFT3 -> 3 | SHIFT4 -> 4 -let print_operation reg pp = function +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) @@ -86,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 @@ -101,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 @@ -108,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 @@ -116,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 < fprintf pp "(%a < fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%Ld -l (%a < 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 @@ -129,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 < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 @@ -138,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 @@ -155,14 +190,14 @@ 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 @@ -184,24 +219,6 @@ let print_operation reg pp = function | Osellimm(cond0, imm), [r1; rc] -> print_condition0 reg pp cond0 rc; fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) - | 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) - | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 - | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) - | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 - | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) - | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) - | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) - | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 - | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 - | (Omaddimm imm), [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) - | (Omaddlimm imm), [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) - | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 - | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 | _, _ -> fprintf pp "" let print_addressing reg pp = function -- cgit From a11f3b87e0535b6c7953c74d00d91fb7d7fbb21b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Jul 2019 11:05:56 +0200 Subject: (#145) Fix on RTL dumps --- mppa_k1c/PrintOp.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 7c408cdf..67f87000 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -222,8 +222,9 @@ let print_operation reg pp op = match op with | _, _ -> fprintf pp "" 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) -- cgit From 98c22a6f37c7230faf80b6366aaa1c2476f9e67c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 25 Jul 2019 14:29:28 +0200 Subject: (#139) - Mise à jour du code Coq, oracle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassScheduling.v | 55 ++++++++++++++++++++++++++++++------ mppa_k1c/PostpassSchedulingOracle.ml | 14 +++++++-- mppa_k1c/PostpassSchedulingproof.v | 2 +- 3 files changed, 59 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 15cb4c48..76757eba 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -19,7 +19,7 @@ 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". @@ -333,10 +333,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 +389,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 +402,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 +421,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. @@ -435,8 +474,8 @@ Proof. 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. + 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. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fd03a80c..40f1d9c7 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -961,10 +961,18 @@ 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 +(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *) + +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) + +(** Called schedule function from Coq *) + +let schedule bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 5d4fc881..0edaf4e2 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -798,7 +798,7 @@ Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: 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. -- cgit From 211382d21013c038c3c716454fcfa5a375dba8ba Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 11:15:15 +0200 Subject: (#139) - Predicate is_concat --- mppa_k1c/PostpassScheduling.v | 15 ++++++++------- mppa_k1c/PostpassSchedulingproof.v | 2 +- 2 files changed, 9 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 76757eba..8b6de1e2 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -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 @@ -466,14 +467,14 @@ 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. + 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. @@ -482,13 +483,13 @@ 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/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 0edaf4e2..2207a2fa 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -736,7 +736,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. -- cgit From 5b4560bd853cbcf1ef195da1b625f37609ec00ec Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 11:33:51 +0200 Subject: (#139) - Quelques renommages --- mppa_k1c/Asmblock.v | 2 +- mppa_k1c/Asmblockdeps.v | 10 +++++----- mppa_k1c/Asmvliw.v | 8 ++++---- mppa_k1c/PostpassSchedulingproof.v | 4 ++-- 4 files changed, 12 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ddb7ce7d..0a25e81a 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -286,7 +286,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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9855afa2..a7fa5cff 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -846,7 +846,7 @@ 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 *) @@ -1004,7 +1004,7 @@ Proof. induction bdy as [|i bdy]; simpl; eauto. intros. exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. - destruct (parexec_basic_instr _ _ _ _ _ _); simpl. + destruct (bstep _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. @@ -1015,7 +1015,7 @@ Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: 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. @@ -1071,9 +1071,9 @@ 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. + 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. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c5b7db45..c6dd85f4 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1355,7 +1355,7 @@ 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 @@ -1414,7 +1414,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 @@ -1550,12 +1550,12 @@ 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 f bdy ext size_b (rs: regset) (m: mem): outcome := match parexec_wio_body bdy rs rs m m with - | Next rsw mw => parexec_exit f ext size_b rs rsw mw + | Next rsw mw => estep f ext size_b rs rsw mw | Stuck => Stuck end. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2207a2fa..21af276b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -240,7 +240,7 @@ Lemma exec_basic_instr_pc_var: 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. + 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). @@ -681,7 +681,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. -- cgit From ce33586e40bf7be637b932d363275b9d5761a3a0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 16:46:16 +0200 Subject: (#156) - Un peu de cleaning et de doc --- mppa_k1c/Archi.v | 3 +- mppa_k1c/Asm.v | 50 ++------- mppa_k1c/Asmaux.v | 2 +- mppa_k1c/Asmblock.v | 33 +----- mppa_k1c/Asmblockdeps.v | 35 +++--- mppa_k1c/Asmblockgen.v | 66 ++---------- mppa_k1c/Asmblockgenproof0.v | 86 ++------------- mppa_k1c/Asmblockgenproof1.v | 246 +------------------------------------------ mppa_k1c/Asmgenproof.v | 4 +- mppa_k1c/Asmvliw.v | 25 +---- 10 files changed, 53 insertions(+), 497 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 113f5d51..96571841 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -14,10 +14,9 @@ (* *) (* *********************************************************************) -(** Architecture-dependent parameters for RISC-V *) +(** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) Require Import ZArith. -(*From Flocq*) Require Import Binary Bits. Definition ptr64 := true. diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 620aa91e..1964e5f8 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -15,7 +15,13 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for K1c assembly language. *) +(** * 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. @@ -57,10 +63,6 @@ Inductive instruction : Type := | 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 *) @@ -101,6 +103,8 @@ Inductive instruction : Type := | Pafaddw (addr: ireg) (incr_res: ireg) | Palclrd (dst: ireg) (addr: ireg) | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) @@ -571,12 +575,6 @@ 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) @@ -650,35 +648,6 @@ Proof. 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), @@ -716,7 +685,6 @@ 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. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 85359658..94b39f4e 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 *) +(** 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 0a25e81a..9b4489c5 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. @@ -172,7 +172,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 +249,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. @@ -302,29 +298,8 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := 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. -(** Execution of a single control-flow instruction [i] in initial state [rs] and - [m]. Return updated state. - - As above: PC is assumed to be incremented on the next block before the control-flow instruction - - 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. - - 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 exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := @@ -368,16 +343,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 +356,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 a7fa5cff..2d144bb6 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,3 +1,10 @@ +(** * 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. @@ -17,6 +24,8 @@ Require Import Chunks. Open Scope impure. +(** Definition of L *) + Module P<: ImpParam. Module R := Pos. @@ -459,18 +468,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. @@ -550,7 +547,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 @@ -574,9 +571,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 := @@ -720,7 +714,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. @@ -1162,7 +1156,7 @@ Proof. destruct (prun_iw _ _ _ _); simpl; eauto. Qed. -(* sequential execution *) +(** sequential execution *) Theorem bisimu_basic ge fn bi rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> @@ -1264,7 +1258,6 @@ Qed. End SECT_PAR. - Section SECT_BBLOCK_EQUIV. Variable Ge: genv. @@ -1294,6 +1287,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") @@ -1645,4 +1640,4 @@ Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). -Qed. \ No newline at end of file +Qed. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e5b9b35a..7e415c2a 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. @@ -41,23 +42,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 +59,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 +79,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 +101,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 +148,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 @@ -1052,7 +1017,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) := @@ -1096,20 +1061,12 @@ 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 := @@ -1120,8 +1077,7 @@ Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := | _ => false 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 @@ -1147,20 +1103,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 => @@ -1168,7 +1115,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/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 89d41017..decc3e2e 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/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. @@ -31,19 +37,13 @@ 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. @@ -277,24 +277,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 -> @@ -607,15 +589,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 +612,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]. *) @@ -850,18 +830,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 -> @@ -973,18 +941,6 @@ Proof. - 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 +953,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 +971,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 +1021,6 @@ Qed. End STRAIGHTLINE. - (** * Properties of the Machblock call stack *) Section MATCH_STACK. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index bc549b4a..e1e2b0b0 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -15,6 +15,8 @@ (* *) (* *********************************************************************) +(** * 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. @@ -86,31 +88,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 +118,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 +138,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 +163,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 @@ -1522,99 +1404,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 := @@ -1868,33 +1657,6 @@ 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. @@ -2555,8 +2317,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/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index e7e21a18..e0878c7d 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. @@ -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 c6dd85f4..72584d2a 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 @@ -152,9 +149,6 @@ Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := 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 *) @@ -251,16 +243,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) -- cgit From 595db90221d4f45682ec5aaac0b485ff32af09e5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 17:47:58 +0200 Subject: begin implementing minf/maxf --- mppa_k1c/ExtFloats.v | 33 +++++++++++++++++++++++++++++++++ mppa_k1c/ExtValues.v | 25 +++++++++++++++++++++++++ mppa_k1c/NeedOp.v | 4 ++-- mppa_k1c/Op.v | 40 ++++++++++++++++++++++++++++++++-------- mppa_k1c/ValueAOp.v | 37 ++++++++++++++++++++++++++++++++++++- 5 files changed, 128 insertions(+), 11 deletions(-) create mode 100644 mppa_k1c/ExtFloats.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v new file mode 100644 index 00000000..efea278b --- /dev/null +++ b/mppa_k1c/ExtFloats.v @@ -0,0 +1,33 @@ +Require Import Floats. + +Module ExtFloat. +(** TODO check with the actual K1c *) + +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. +End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3370fae3..a785375b 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,6 +1,7 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Require Import ExtFloats. Inductive shift1_4 : Type := | SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. @@ -671,3 +672,27 @@ Definition revsubx sh v1 v2 := 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. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 4748f38b..84e32d0f 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -121,9 +121,9 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | 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) | Onegfs | Oabsfs => op1 (default nv) - | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 35fbb596..4beef520 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -179,12 +179,16 @@ Inductive operation : Type := | Osubf (**r [rd = r1 - r2] *) | Omulf (**r [rd = r1 * r2] *) | Odivf (**r [rd = r1 / r2] *) + | Ominf + | Omaxf | 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 | 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: *) @@ -426,12 +430,16 @@ 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) | 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) | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -630,16 +638,20 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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) | 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) | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -906,6 +918,9 @@ 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... (* negfs, absfs *) - destruct v0... - destruct v0... @@ -915,6 +930,9 @@ 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... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -1517,6 +1535,9 @@ 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. (* negfs, absfs *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1526,6 +1547,9 @@ 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. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 439138da..0e9ce506 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -12,7 +12,12 @@ 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. (** Value analysis for RISC V operators *) @@ -235,12 +240,16 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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 | 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 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -278,6 +287,32 @@ 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. + +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound : va. + Theorem eval_static_condition_sound: forall cond vargs m aargs, list_forall2 (vmatch bc) vargs aargs -> -- cgit From 51094cecd5d24023e3de2487e66765f8c54b5fcc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 19:33:33 +0200 Subject: fmin/fmax/fminf/fmaxf non bien testés MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 8 ++++++++ mppa_k1c/Asmblockdeps.v | 4 ++++ mppa_k1c/Asmblockgen.v | 12 ++++++++++++ mppa_k1c/Asmvliw.v | 9 +++++++++ mppa_k1c/Builtins1.v | 28 +++++++++++++++++++++++----- mppa_k1c/CBuiltins.ml | 10 ++++++++-- mppa_k1c/ExtFloats.v | 3 ++- mppa_k1c/PostpassSchedulingOracle.ml | 10 +++++++++- mppa_k1c/SelectOp.vp | 8 +++++++- mppa_k1c/SelectOpproof.v | 4 +++- mppa_k1c/TargetPrinter.ml | 8 ++++++++ 11 files changed, 93 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 620aa91e..35eebb11 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -227,6 +227,10 @@ Inductive instruction : Type := | 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 *) (** Arith RRI32 *) | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) @@ -395,6 +399,10 @@ Definition basic_to_instruction (b: basic) := | 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9855afa2..cb219f00 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1423,6 +1423,10 @@ 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 := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e5b9b35a..1f3f7539 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -775,6 +775,18 @@ 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) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c5b7db45..a733b54c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -470,6 +470,10 @@ 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 := @@ -1072,6 +1076,11 @@ Definition arith_eval_rrr n 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 diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index f6e643d2..73d1bcf4 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -16,18 +16,36 @@ (** Platform-specific built-in functions *) Require Import String Coqlib. -Require Import AST Integers Floats Values. +Require Import AST Integers Floats Values ExtFloats. Require Import Builtins0. -Inductive platform_builtin : Type := . +Inductive platform_builtin : Type := +| BI_fmin +| BI_fmax +| BI_fminf +| BI_fmaxf. Local Open Scope string_scope. Definition platform_builtin_table : list (string * platform_builtin) := - nil. + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: ("__builtin_fminf", BI_fminf) + :: ("__builtin_fmaxf", BI_fmaxf) + :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := - match b with end. + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + | BI_fminf | BI_fmaxf => + mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := - match b with end. + 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 + end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 09a9ba97..43f3d98c 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -114,14 +114,20 @@ 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_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); +] } let va_list_type = TPtr(TVoid [], []) (* to check! *) diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index efea278b..090844f6 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -1,7 +1,8 @@ Require Import Floats. Module ExtFloat. -(** TODO check with the actual K1c *) +(** 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 diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 895f9f40..21cabfe9 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -31,6 +31,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fmind | Fminw | Fmaxd | Fmaxw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz | Fcompw | Fcompd @@ -119,6 +120,10 @@ let arith_rrr_real = function | Pfsbfw -> Fsbfw | Pfmuld -> Fmuld | Pfmulw -> Fmulw + | Pfmind -> Fmind + | Pfminw -> Fminw + | Pfmaxd -> Fmaxd + | Pfmaxw -> Fmaxw let arith_rri32_real = function | Pcompiw it -> Compw @@ -578,10 +583,12 @@ let rec_to_usage r = | Some E27U27L10 -> lsu_acc_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 + let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw @@ -590,6 +597,7 @@ let real_inst_to_latency = function | Nandd | Nord | Nxord | Ornd | Andnd | 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 | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 688820b3..72597a2b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -675,7 +675,13 @@ Definition divfs_base (e1: expr) (e2: expr) := End SELECT. Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := - None. + 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) + end. + (* Local Variables: *) (* mode: coq *) (* End: *) \ No newline at end of file diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index e009ed98..65685201 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1641,7 +1641,9 @@ Theorem eval_platform_builtin: platform_builtin_sem bf vl = Some v -> exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. Proof. - intros. discriminate. + destruct bf; intros until le; intro Heval; inversion Heval; subst a; clear Heval. + all: exists v; split; trivial; + try repeat (try econstructor; try eassumption). Qed. End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index dafad7fb..3ff016c2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -628,6 +628,14 @@ 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 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> -- cgit From c0984982ea5b8481bfc75c0ea4254eb5db07d875 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 21:46:52 +0200 Subject: fabsf --- mppa_k1c/Builtins1.v | 7 ++++++- mppa_k1c/CBuiltins.ml | 3 +++ mppa_k1c/SelectOp.vp | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 73d1bcf4..5187ea7d 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -23,7 +23,8 @@ Inductive platform_builtin : Type := | BI_fmin | BI_fmax | BI_fminf -| BI_fmaxf. +| BI_fmaxf +| BI_fabsf. Local Open Scope string_scope. @@ -32,6 +33,7 @@ Definition platform_builtin_table : list (string * platform_builtin) := :: ("__builtin_fmax", BI_fmax) :: ("__builtin_fminf", BI_fminf) :: ("__builtin_fmaxf", BI_fmaxf) + :: ("__builtin_fabsf", BI_fabsf) :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := @@ -40,6 +42,8 @@ Definition platform_builtin_sig (b: platform_builtin) : signature := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default | BI_fminf | BI_fmaxf => mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + | BI_fabsf => + mksignature (Tsingle :: nil) (Some Tsingle) cc_default end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := @@ -48,4 +52,5 @@ Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_re | 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 end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 43f3d98c..c0022cb1 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -115,6 +115,9 @@ let builtins = { "__builtin_fnmsub", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) + "__builtin_fabsf", + (TFloat(FFloat, []), + [TFloat(FFloat, [])], false); "__builtin_fmax", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 72597a2b..c8139ecb 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -680,6 +680,7 @@ Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr | BI_fmax => Some (Eop Omaxf args) | BI_fminf => Some (Eop Ominfs args) | BI_fmaxf => Some (Eop Omaxfs args) + | BI_fabsf => Some (Eop Oabsfs args) end. (* Local Variables: *) -- cgit From cfc681ae18c59f4a19143a7245be23eb6a4045a0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 10:10:06 +0200 Subject: add finvw ; not yet generated --- mppa_k1c/Asm.v | 4 +++- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 3 +++ mppa_k1c/Asmvliw.v | 2 ++ mppa_k1c/ExtFloats.v | 6 +++++- mppa_k1c/ExtValues.v | 6 ++++++ mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 7 +++++++ mppa_k1c/PostpassSchedulingOracle.ml | 7 ++++--- mppa_k1c/TargetPrinter.ml | 2 ++ mppa_k1c/ValueAOp.v | 22 +++++++++++++++++++++- 11 files changed, 55 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 35eebb11..b7818aaf 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -231,7 +231,8 @@ Inductive instruction : Type := | 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 *) @@ -327,6 +328,7 @@ Definition basic_to_instruction (b: basic) := | 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index cb219f00..61caeaf1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1343,6 +1343,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" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 1f3f7539..c2a36ff7 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -793,6 +793,9 @@ Definition transl_op | 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) | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index a733b54c..cb9ce7ae 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -392,6 +392,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) *) @@ -996,6 +997,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 diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index 090844f6..b2fc6581 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -1,4 +1,4 @@ -Require Import Floats. +Require Import Floats Integers ZArith. Module ExtFloat. (** TODO check with the actual K1c; @@ -31,4 +31,8 @@ Definition max (x : float32) (y : float32) : float32 := | Some Eq | Some Gt => x | Some Lt | None => y end. + +Definition inv (x : float32) : float32 := + Float32.div (Float32.of_int (Int.repr (1%Z))) x. + End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index a785375b..9cec5669 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -696,3 +696,9 @@ Definition maxfs v1 v2 := | (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. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 84e32d0f..856f5b54 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -124,6 +124,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) + | Oinvfs => op1 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4beef520..de372157 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -189,6 +189,7 @@ Inductive operation : Type := | Odivfs (**r [rd = r1 / r2] *) | Ominfs | Omaxfs + | Oinvfs | 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: *) @@ -440,6 +441,7 @@ Definition eval_operation | 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) | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -652,6 +654,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Odivfs | Ominfs | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oinvfs => (Tsingle :: nil, Tsingle) | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -933,6 +936,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* minfs, maxfs *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* invfs *) + - destruct v0... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -1550,6 +1555,8 @@ Proof. (* minfs, maxfs *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* invfs *) + - inv H4; simpl; auto. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 21cabfe9..e2baa2c0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -31,7 +31,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fmind | Fminw | Fmaxd | Fmaxw + | Fmind | Fminw | Fmaxd | Fmaxw | Finvw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz | Fcompw | Fcompd @@ -62,6 +62,7 @@ let arith_rr_real = function | Pfabsd -> Fabsd | Pfnegw -> Fnegw | Pfnegd -> Fnegd + | Pfinvw -> Finvw | Pfnarrowdw -> Fnarrowdw | Pfwidenlwd -> Fwidenlwd | Pfloatwrnsz -> Floatwz @@ -586,7 +587,7 @@ let rec_to_usage r = | 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 -> mau let real_inst_to_latency = function @@ -607,7 +608,7 @@ let real_inst_to_latency = function | 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 -> 4 let rec_to_info r : inst_info = let usage = rec_to_usage r diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3ff016c2..3d3b56a2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -636,6 +636,8 @@ module Target (*: TARGET*) = 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) -> diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 0e9ce506..edbdc0b2 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -19,6 +19,15 @@ Definition maxf := binop_float ExtFloat.max. Definition minfs := binop_single ExtFloat32.min. Definition maxfs := binop_single ExtFloat32.max. +Definition invfs (y : aval) := + match y with + | FS f => FS (ExtFloat32.inv f) + | _ => ntop1 y + end. + +Definition binop_float (sem: float -> float -> float) (x y: aval) := + match x, y with F n, F m => F (sem n m) | _, _ => ntop2 x y end. + (** Value analysis for RISC V operators *) Definition eval_static_condition (cond: condition) (vl: list aval): abool := @@ -250,6 +259,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -311,7 +321,17 @@ Proof. apply (binop_single_sound bc ExtFloat32.max); assumption. Qed. -Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound : va. +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. + +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound : va. Theorem eval_static_condition_sound: forall cond vargs m aargs, -- cgit From 344fd96e0690ff4809623198baeee823132f7219 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 12:30:16 +0200 Subject: use finvw --- mppa_k1c/ExtFloats.v | 3 ++- mppa_k1c/SelectOp.vp | 15 +++++++++++++-- mppa_k1c/SelectOpproof.v | 31 ++++++++++++++++++++++++++++++- 3 files changed, 45 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index b2fc6581..d9b9d3a6 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -32,7 +32,8 @@ Definition max (x : float32) (y : float32) : float32 := | Some Lt | None => y end. +Definition one := Float32.of_int (Int.repr (1%Z)). Definition inv (x : float32) : float32 := - Float32.div (Float32.of_int (Int.repr (1%Z))) x. + Float32.div one x. End ExtFloat32. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index c8139ecb..6539184c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -51,7 +51,7 @@ 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. @@ -669,9 +669,20 @@ 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. End SELECT. Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 65685201..7805a1be 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1622,6 +1622,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 -> @@ -1629,7 +1652,13 @@ 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 *) -- cgit From 436bf1192e129427f6fcc99d2e6b75db08e80cf8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 15:08:07 +0200 Subject: (#157) Removed AFADDD and AFADDW from the builtins --- mppa_k1c/Asm.v | 4 ++-- mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/CBuiltins.ml | 4 ++-- mppa_k1c/TargetPrinter.ml | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1964e5f8..a0c5e71c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -99,8 +99,8 @@ Inductive instruction : Type := | Piinvals (addr: ireg) | Pitouchl (addr: ireg) | Pdzerol (addr: ireg) - | Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: 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) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 65dee6c7..20d27951 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -465,14 +465,14 @@ 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)); 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)) + 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) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 2f80c90f..a02da077 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -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 *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 674695d9..2621a43b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -399,10 +399,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) -> +(* | Pafaddd(addr, incr_res) -> fprintf oc " 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 + fprintf oc " 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) -> -- cgit From 21622a06394e68170a9901f316addcd3fd1841de Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 15:38:14 +0200 Subject: Added more tests --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 2621a43b..c9822e13 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -400,9 +400,9 @@ module Target (*: TARGET*) = | 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 + 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 *) (* see #157 *) + 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) -> -- cgit From 1522f289301f37da0324570297c65256d8a32316 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 16:46:11 +0200 Subject: début du fma MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/ExtValues.v | 20 ++++++++++++- mppa_k1c/NeedOp.v | 55 ++++++++++++++++++++++++++++++++-- mppa_k1c/Op.v | 26 ++++++++++++++++ mppa_k1c/ValueAOp.v | 85 +++++++++++++++++++++++++++++++++++++++++++++++++--- 4 files changed, 179 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 9cec5669..3e4b70b5 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,7 +1,7 @@ Require Import Coqlib. Require Import Integers. Require Import Values. -Require Import ExtFloats. +Require Import Floats ExtFloats. Inductive shift1_4 : Type := | SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. @@ -702,3 +702,21 @@ Definition invfs v1 := | (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 Float.fma. +Definition fmaddfs := triple_op_single Float32.fma. + +Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma f1 (Float.neg f2) f3). +Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma f1 (Float32.neg f2) f3). diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 856f5b54..d2d4d5f5 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -122,9 +122,11 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omsubl => op3 (default nv) | Onegf | Oabsf => op1 (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 | 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) @@ -286,7 +288,53 @@ Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. Qed. - + +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. + 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 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. + 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. + +Hint Resolve vagree_triple_op_float vagree_triple_op_single : na. + Lemma needs_of_operation_sound: forall op args v nv args', eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> @@ -345,7 +393,10 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. - (* select *) +- apply vagree_triple_op_float; assumption. +- apply vagree_triple_op_float; assumption. +- apply vagree_triple_op_single; assumption. +- apply vagree_triple_op_single; assumption. - destruct (eval_condition0 _ _ _) as [b|] eqn:EC. erewrite needs_of_condition0_sound by eauto. apply select_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index de372157..b3258259 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -181,6 +181,8 @@ Inductive operation : Type := | Odivf (**r [rd = r1 / r2] *) | Ominf | Omaxf + | Ofmaddf + | Ofmsubf | Onegfs (**r [rd = - r1] *) | Oabsfs (**r [rd = abs(r1)] *) | Oaddfs (**r [rd = r1 + r2] *) @@ -190,6 +192,8 @@ Inductive operation : Type := | 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: *) @@ -433,6 +437,9 @@ Definition eval_operation | 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) @@ -442,6 +449,9 @@ Definition eval_operation | 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 @@ -646,6 +656,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Odivf | Ominf | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) + | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + | Onegfs => (Tsingle :: nil, Tsingle) | Oabsfs => (Tsingle :: nil, Tsingle) | Oaddfs @@ -655,6 +667,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | 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) @@ -924,6 +938,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* 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... @@ -938,6 +955,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - 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... @@ -1543,6 +1563,9 @@ Proof. (* 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. @@ -1557,6 +1580,9 @@ Proof. - 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. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index edbdc0b2..4c5fcf71 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -19,14 +19,30 @@ 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 Float.fma. +Definition fmsubf := triple_op_float (fun x y z => Float.fma x (Float.neg y) z). +Definition fmaddfs := triple_op_single Float32.fma. +Definition fmsubfs := triple_op_single (fun x y z => Float32.fma x (Float32.neg y) z). + Definition invfs (y : aval) := match y with | FS f => FS (ExtFloat32.inv f) | _ => ntop1 y end. - -Definition binop_float (sem: float -> float -> float) (x y: aval) := - match x, y with F n, F m => F (sem n m) | _, _ => ntop2 x y end. (** Value analysis for RISC V operators *) @@ -251,6 +267,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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 @@ -260,6 +278,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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 @@ -331,7 +351,64 @@ Proof. constructor. Qed. -Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound : va. +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, -- cgit From ccd2fa5638e50b5fd8308b4b0c26531f911ff087 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 17:08:07 +0200 Subject: Rajout de clzd dans les tests --- mppa_k1c/CBuiltins.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index a02da077..5fb69f62 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -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); *) -- cgit From caac487ae23a9785602cf235f5b4a2b6749f2c18 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 19:10:42 +0200 Subject: fma --- mppa_k1c/Asm.v | 8 ++++++ mppa_k1c/Asmblockdeps.v | 4 +++ mppa_k1c/Asmblockgen.v | 25 +++++++++++++++++ mppa_k1c/Asmvliw.v | 8 ++++++ mppa_k1c/Builtins1.v | 12 +++++++- mppa_k1c/CBuiltins.ml | 6 ++++ mppa_k1c/ExtValues.v | 8 +++--- mppa_k1c/Machregs.v | 2 ++ mppa_k1c/PostpassSchedulingOracle.ml | 11 ++++++-- mppa_k1c/SelectOp.vp | 16 ++++++++++- mppa_k1c/SelectOpproof.v | 53 ++++++++++++++++++++++++++++++++++-- mppa_k1c/TargetPrinter.ml | 8 ++++++ mppa_k1c/ValueAOp.v | 8 +++--- 13 files changed, 154 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b7818aaf..ce376af9 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -200,6 +200,10 @@ Inductive instruction : Type := | 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 *) @@ -452,6 +456,10 @@ Definition basic_to_instruction (b: basic) := | 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 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 61caeaf1..6743ae4c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1483,6 +1483,10 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := | 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 := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c2a36ff7..c717af95 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -797,6 +797,31 @@ Definition transl_op 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; OK (Pfloatwrnsz rd rs ::i k) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index cb9ce7ae..b0f8501d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -528,6 +528,10 @@ Inductive arith_name_arrr : Type := | 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 := @@ -1177,6 +1181,10 @@ Definition arith_eval_arrr n v1 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 := diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 5187ea7d..6186961f 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -24,7 +24,9 @@ Inductive platform_builtin : Type := | BI_fmax | BI_fminf | BI_fmaxf -| BI_fabsf. +| BI_fabsf +| BI_fma +| BI_fmaf. Local Open Scope string_scope. @@ -34,6 +36,8 @@ Definition platform_builtin_table : list (string * platform_builtin) := :: ("__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 := @@ -44,6 +48,10 @@ Definition platform_builtin_sig (b: platform_builtin) : signature := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default | BI_fabsf => mksignature (Tsingle :: nil) (Some Tsingle) cc_default + | BI_fma => + mksignature (Tfloat :: Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + | BI_fmaf => + mksignature (Tsingle :: Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := @@ -53,4 +61,6 @@ Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_re | 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 c0022cb1..3ae6baa7 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -130,6 +130,12 @@ let builtins = { "__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); ] } diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3e4b70b5..a8e24c86 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -715,8 +715,8 @@ Definition triple_op_single f v1 v2 v3 := | _, _, _ => Vundef end. -Definition fmaddf := triple_op_float Float.fma. -Definition fmaddfs := triple_op_single Float32.fma. +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 f1 (Float.neg f2) f3). -Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma f1 (Float32.neg f2) f3). +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/Machregs.v b/mppa_k1c/Machregs.v index 5a7d42b4..8098b5d1 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -213,6 +213,8 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with + | Ofmaddf | Ofmaddfs + | Ofmsubf | Ofmsubfs | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index e2baa2c0..628ae609 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -32,6 +32,7 @@ type real_instruction = | 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 @@ -173,6 +174,10 @@ let arith_arr_real = function | Pinsfl (_, _) -> Insf let arith_arrr_real = function + | Pfmaddfw -> Ffmaw + | Pfmaddfl -> Ffmad + | Pfmsubfw -> Ffmsw + | Pfmsubfl -> Ffmsd | Pmaddw -> Maddw | Pmaddl -> Maddd | Pmsubw -> Msbfw @@ -587,7 +592,8 @@ let rec_to_usage r = | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite | Fnarrowdw -> alu_full - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw -> mau + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau let real_inst_to_latency = function @@ -608,7 +614,8 @@ let real_inst_to_latency = function | 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 | Finvw -> 4 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4 let rec_to_info r : inst_info = let usage = rec_to_usage r diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6539184c..71078046 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -683,7 +683,18 @@ Nondetfunction divfs_base (e1: expr) := else divfs_baseX e1) | _ => divfs_baseX e1 end. -End SELECT. + +Nondetfunction gen_fma args := + match args with + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Nondetfunction gen_fmaf args := + match args with + | 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 @@ -692,7 +703,10 @@ Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr | 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: *) (* mode: coq *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7805a1be..08bcff12 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1663,6 +1663,50 @@ 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. + inversion Heval; subst a; clear Heval. + intro; InvEval. + 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. + inversion Heval; subst a; clear Heval. + intro; InvEval. + 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 -> @@ -1670,9 +1714,12 @@ Theorem eval_platform_builtin: 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; inversion Heval; subst a; clear Heval. - all: exists v; split; trivial; - try repeat (try econstructor; try eassumption). + 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 3d3b56a2..e626d2b4 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -574,6 +574,10 @@ module Target (*: TARGET*) = fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | 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 @@ -615,6 +619,10 @@ module Target (*: TARGET*) = 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 diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 4c5fcf71..2c9bdf3e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -33,10 +33,10 @@ Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y | _, _, _ => ntop3 x y z end. -Definition fmaddf := triple_op_float Float.fma. -Definition fmsubf := triple_op_float (fun x y z => Float.fma x (Float.neg y) z). -Definition fmaddfs := triple_op_single Float32.fma. -Definition fmsubfs := triple_op_single (fun x y z => Float32.fma x (Float32.neg y) z). +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 -- cgit From 9a19f2fdf735785947cc469d2ceef83cbe4f1679 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 19:23:24 +0200 Subject: fma with first negated operand --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 20 ++++++++++++++------ 2 files changed, 16 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 71078046..ec3985c5 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -686,12 +686,14 @@ Nondetfunction divfs_base (e1: expr) := 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. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 08bcff12..583fb545 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1674,9 +1674,13 @@ Proof. intros until le. intro Heval. destruct (gen_fma_match _) in *; try discriminate. - inversion Heval; subst a; clear Heval. - intro; InvEval. - intro Heval. + 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. @@ -1696,9 +1700,13 @@ Proof. intros until le. intro Heval. destruct (gen_fmaf_match _) in *; try discriminate. - inversion Heval; subst a; clear Heval. - intro; InvEval. - intro Heval. + 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. -- cgit From 7c790ecd1c32b529a5e5e5977ce84cfade8e1eb6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 31 Aug 2019 09:16:44 +0200 Subject: some more proofs on integers, preparing for absolute value instruction --- mppa_k1c/ExtValues.v | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3370fae3..e9c62a8d 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -2,6 +2,24 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +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. -- cgit From 71c58a8d494eafd847776446b0c246229b2bc9cf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Sep 2019 18:30:25 +0200 Subject: avancement (il faut utiliser Vundef visiblement) --- mppa_k1c/Op.v | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 815d3958..f3ee0577 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1649,6 +1649,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. *) @@ -1755,6 +1776,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. *) -- cgit From 1fbd5d18a9f4398d7ecb9b9ab148a96f575fd1e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 09:51:22 +0200 Subject: Englishification of comments --- mppa_k1c/lib/Machblock.v | 4 ++-- mppa_k1c/lib/Machblockgen.v | 13 ++++--------- 2 files changed, 6 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 30393fd5..2759c49d 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -14,7 +14,7 @@ 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 @@ -26,7 +26,7 @@ Inductive basic_inst: Type := 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 diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index 4dfc309e..db48934e 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -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,7 +98,7 @@ 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 -- cgit From 2bf7b92601fd6f33f93609c85a79192f821e6637 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 12:57:15 +0200 Subject: compatibility with OCaml 4.08 --- mppa_k1c/InstructionScheduler.ml | 5 ++--- mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index e182804b..9d3503e2 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,9 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(* FIXME DUMMY CODE to placate warnings - *) -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;; 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;; -- cgit From 5177f34535a70e4335dbab3a66c916c976405df7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 18:27:40 +0200 Subject: Value analysis for non trapping loads --- mppa_k1c/ValueAOp.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 2c9bdf3e..5e9eb455 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,6 +472,26 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. +(* not needed +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 -> -- cgit From e8676a19cf20cf65eb3c57b6621919d3d7ffc065 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 21:22:13 +0200 Subject: forgot this function --- mppa_k1c/ValueAOp.v | 2 -- 1 file changed, 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 5e9eb455..7d84447e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,7 +472,6 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. -(* not needed Theorem eval_static_addressing_sound_none: forall addr vargs aargs, eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> @@ -490,7 +489,6 @@ Proof. inv H3; destruct addr; trivial; discriminate. Qed. - *) Theorem eval_static_operation_sound: forall op vargs m vres aargs, -- cgit From 4284ab56c71cd64ebf6ce22ad13d3cd5533ac7ed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 12:10:11 +0200 Subject: more on notrap --- mppa_k1c/Asmblockgen.v | 19 ++++++++++++------- mppa_k1c/Asmblockgenproof1.v | 34 ++++++++++++++++++++++++++-------- mppa_k1c/lib/Machblock.v | 17 ++++++++++++++--- mppa_k1c/lib/Machblockgen.v | 2 +- mppa_k1c/lib/Machblockgenproof.v | 4 ++++ 5 files changed, 57 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..cd9b3202 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1008,12 +1008,17 @@ Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) do r <- ireg_of dst; transl_memory_access2XS chunk (PLoadRRRXS (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 + match trap with + | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") + | TRAP => + 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 + end end. Definition chunk2store (chunk: memory_chunk) := @@ -1073,8 +1078,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. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e1e2b0b0..ce01041d 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1947,9 +1947,9 @@ Proof. 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, @@ -1958,6 +1958,8 @@ Lemma transl_load_memory_access_ok: /\ forall base ofs rs, exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. Proof. + destruct trap. + { (* TRAP *) intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). @@ -1967,12 +1969,15 @@ Proof. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity | eauto ]. + } + intros until m. intros ADDR TR ? ?. + monadInv TR. Qed. Lemma transl_load_memory_access2_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, addr = Aindexed2 -> - 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 mr0 mro rd ro, @@ -1983,17 +1988,24 @@ Lemma transl_load_memory_access2_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) 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]. + } + { (* NOTRAP *) + intros until m. intros ? TR ? ?. + unfold transl_load in TR. subst. monadInv TR. + } 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, @@ -2004,17 +2016,23 @@ Lemma transl_load_memory_access2XS_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) 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]. + } + { (* NOTRAP *) + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. } 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', diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 2759c49d..5a7f1782 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -20,7 +20,7 @@ Inductive basic_inst: Type := | 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 . @@ -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 db48934e..a65b218f 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. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..77db094d 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -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. -- cgit From 339d7e5ff093a2002aa8c939aece10bafe2914d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:16:05 +0200 Subject: more proofs --- mppa_k1c/Op.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c75a1a22..7aea2929 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1903,6 +1903,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 -> -- cgit From 7556ba3dc77b1811b8a1063acc45ac1972865363 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:58:54 +0200 Subject: more stuff on non trapping loads --- mppa_k1c/Asmblockgenproof.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..828e4665 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,6 +1204,14 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. + - (* MBload notrap1 TODO *) + simpl in EQ0. + discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. + discriminate. + - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. -- cgit From 5a095e968ca040757db22a4bd7cde34b91bf44e1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 5 Sep 2019 14:25:21 +0200 Subject: Removing unused .all, .any, .nall and .none conditions --- mppa_k1c/Asmvliw.v | 13 ------------- mppa_k1c/TargetPrinter.ml | 4 ---- 2 files changed, 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 54654abb..54e9c847 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -203,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 := @@ -909,10 +904,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 := @@ -929,10 +920,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 diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5618875f..0c179a07 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -262,10 +262,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) -- cgit From 68da36573f9e6e0109095eb74da5f5ec74202b8e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 16:16:53 +0200 Subject: moving forward on K1C --- mppa_k1c/Asm.v | 82 +++++++++++++++++----------------- mppa_k1c/Asmblock.v | 6 +-- mppa_k1c/Asmblockdeps.v | 103 +++++++++++++++++++++++++++---------------- mppa_k1c/Asmblockgen.v | 38 +++++++--------- mppa_k1c/Asmblockgenproof0.v | 30 +++++++------ mppa_k1c/Asmblockgenproof1.v | 54 ++++++++--------------- mppa_k1c/Asmvliw.v | 49 +++++++++++++------- mppa_k1c/Peephole.v | 9 ++-- 8 files changed, 200 insertions(+), 171 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e37176ef 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -107,16 +107,16 @@ Inductive instruction : Type := | Pstsud (rd rs1 rs2: 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 *) + | 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 *) @@ -481,41 +481,41 @@ Definition basic_to_instruction (b: basic) := | 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 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) + | 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 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) + | 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) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9b4489c5..91e5ac89 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -260,11 +260,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. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..65792d13 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -83,9 +83,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. @@ -142,33 +142,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. @@ -364,24 +370,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. @@ -617,21 +646,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))] @@ -861,21 +890,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. @@ -1537,9 +1566,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 := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index cd9b3202..fd50f3b4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -912,12 +912,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. @@ -933,7 +933,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. @@ -993,32 +993,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 (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match trap with - | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") - | TRAP => - 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 - end + match addr with + | 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) := diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index decc3e2e..07c445e2 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -897,34 +897,36 @@ Lemma exec_basic_instr_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 *) + 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 *) + 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 *) + 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 *) + 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. @@ -932,7 +934,7 @@ Proof. 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. + 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. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ce01041d..68f21541 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1661,9 +1661,9 @@ 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', @@ -1716,7 +1716,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. @@ -1784,7 +1784,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: @@ -1877,11 +1879,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' -> @@ -1900,11 +1902,11 @@ Proof. 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' -> @@ -1926,9 +1928,9 @@ Proof. 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' -> @@ -1956,22 +1958,17 @@ Lemma transl_load_memory_access_ok: 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. - destruct trap. - { (* TRAP *) 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 ]. - } - intros until m. intros ADDR TR ? ?. - monadInv TR. Qed. Lemma transl_load_memory_access2_ok: @@ -1986,21 +1983,14 @@ Lemma transl_load_memory_access2_ok: /\ preg_of mro = IR ro /\ transl_memory_access2 mk_instr addr 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. - destruct trap. - { (* TRAP *) 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]. - } - { (* NOTRAP *) - intros until m. intros ? TR ? ?. - unfold transl_load in TR. subst. monadInv TR. - } Qed. Lemma transl_load_memory_access2XS_ok: @@ -2014,20 +2004,14 @@ 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. - destruct trap. - { (* TRAP *) 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]. - } - { (* NOTRAP *) - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. } Qed. Lemma transl_load_correct: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 54654abb..bfe9d77b 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,6 +313,16 @@ Inductive cf_instruction : Type := . (** Loads **) +Definition concrete_default_notrap_load_value 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 *) @@ -327,9 +337,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) . @@ -1215,10 +1225,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 @@ -1263,15 +1279,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. @@ -1284,7 +1300,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' @@ -1342,7 +1359,7 @@ Definition load_chunk n := | Pfls => Mfloat32 | Pfld => Mfloat64 end. - + Definition store_chunk n := match n with | Psb => Mint8unsigned @@ -1361,12 +1378,12 @@ 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 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 -- cgit From 22e78b34ca993e0ff1f79c943b16122b1067bd74 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:22:40 +0200 Subject: further --- mppa_k1c/Asmblockgenproof.v | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 828e4665..67f02520 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,9 +1204,26 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - (* MBload notrap1 TODO *) - simpl in EQ0. - discriminate. + - simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = None). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. + intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. + 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. - (* MBload notrap2 TODO *) simpl in EQ0. -- cgit From 2b2ad7fc33fecfd77598e485ae0af82be3f23471 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:40:56 +0200 Subject: moving forward with notrap --- mppa_k1c/Asmblockgenproof.v | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 67f02520..15655db6 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,30 +1204,18 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = None). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. - intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. - 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. + - (* 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. - discriminate. + admit. - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1253,7 +1241,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Qed. +Admitted. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, -- cgit From a57ba1a8a0036853cac31d9401a6f71b877e70c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:50:34 +0200 Subject: a couple "Admitted" and the Coq compiles --- mppa_k1c/PostpassSchedulingproof.v | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 21af276b..867c10c5 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -96,36 +96,42 @@ Proof. 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'. + 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. - - 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 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'. + 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. - - 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 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'. + 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. - - 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: -- cgit From 74699fa95d096dfc5b9ed7d60aaf1a1338bfc950 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:21:37 +0200 Subject: notrap in mppa_k1c ML code --- mppa_k1c/Asmexpand.ml | 34 +++++++++++++++++----------------- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- mppa_k1c/TargetPrinter.ml | 28 ++++++++++++++++------------ 3 files changed, 35 insertions(+), 31 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1e5149fd..5a103915 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 diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fa61d588..41dac766 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -302,7 +302,7 @@ let arith_rec i = | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with - | PLoadRRO (i, rs1, rs2, imm) -> + | 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) -> @@ -313,7 +313,7 @@ let load_rec i = match i with let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in { 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 (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> + | 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 = [] } diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5618875f..609077c6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -251,6 +251,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" @@ -424,18 +428,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) -> -- cgit From 5898702ac91da16b487b7debb522a440c296fa93 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:53:01 +0200 Subject: more proofs on notrap --- mppa_k1c/Asmblockgenproof1.v | 130 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 124 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 68f21541..55fca89a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1927,6 +1927,32 @@ Proof. split; intros; Simpl. auto. 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 trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, @@ -1971,21 +1997,65 @@ Proof. | eauto ]. Qed. -Lemma transl_load_memory_access2_ok: - forall addr trap chunk args dst k c rs a v m, - addr = Aindexed2 -> - transl_load trap 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 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 @@ -2014,6 +2084,28 @@ Proof. | 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 trap chunk addr args dst k c (rs: regset) m a v, transl_load trap chunk addr args dst k = OK c -> @@ -2040,6 +2132,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; 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; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; 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 -> -- cgit From be40bfa8516ab7c2b2f5d5c542af73a4f7b8148e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:02:28 +0200 Subject: more proofs on notrap2 --- mppa_k1c/Asmblockgenproof1.v | 62 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 55fca89a..c0a05ab3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1901,6 +1901,29 @@ 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 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 -> @@ -1924,7 +1947,7 @@ 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: @@ -1974,6 +1997,27 @@ 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 trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> @@ -2144,18 +2188,18 @@ Lemma transl_load_correct_notrap2: 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; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + 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; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + 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; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + 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; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + 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; eauto with asmgen. + eapply transl_load_access_correct_notrap2; eauto with asmgen. Qed. Lemma transl_store_access2_correct: -- cgit From 7df2b7d824f3187f1936685629c06d1028fdc243 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:53:08 +0200 Subject: asmblockgen works --- mppa_k1c/Asmblockgenproof.v | 51 +++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/Asmvliw.v | 2 +- 2 files changed, 48 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 15655db6..6baca8c0 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1214,9 +1214,52 @@ Local Transparent destroyed_by_op. destruct t1 as [|h2 t2]; try discriminate. - (* MBload notrap2 TODO *) - simpl in EQ0. - admit. - + 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. + 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. + } + { + 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. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. + } - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1241,7 +1284,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Admitted. +Qed. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index bfe9d77b..9508bfbd 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,7 +313,7 @@ Inductive cf_instruction : Type := . (** Loads **) -Definition concrete_default_notrap_load_value chunk := +Definition concrete_default_notrap_load_value (chunk : memory_chunk) := match chunk with | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned | Mint32 => Vint Int.zero -- cgit From a1b4ed93ca2b7a244fb5d6d54c0bd0737f618837 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 13 Sep 2019 17:43:27 +0200 Subject: Compatibility fix for Coq 8.7.1 --- mppa_k1c/lib/Machblockgenproof.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..ab7fff74 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -715,17 +715,17 @@ 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. + Focus 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. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. } + simpl in H5; congruence. all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From a42baf15372e64f398685aaef079a82ea0db834e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Sep 2019 14:05:09 +0200 Subject: Timings for Machblockgen, Asmblockgen and postpass scheduling --- mppa_k1c/Asmgen.v | 12 +++++++----- mppa_k1c/Asmgenproof.v | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 58e80be1..704a0ac5 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -18,15 +18,17 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. -Require Import Errors. +Require Import Errors String. Local Open Scope error_monad_scope. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := 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 optimization" 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 e0878c7d..5d7bb81f 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -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 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. -- cgit From 7f1025fa2da08e68b839b7b6ea89771822dcfe83 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Sep 2019 14:26:17 +0200 Subject: Detailing oracle/vérificateur in the timings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmgen.v | 2 +- mppa_k1c/PostpassSchedulingOracle.ml | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 704a0ac5..c3588871 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -27,7 +27,7 @@ Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; - do abp' <- (time "PostpassScheduling optimization" PostpassScheduling.transf_program) abp; + 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 := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fa61d588..327901f3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -991,4 +991,5 @@ let rec bundles_to_coq_schedule = function (** Called schedule function from Coq *) -let schedule bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto +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 -- cgit From 1801685f8352b7a120d87d5b529d290728129529 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Sep 2019 14:32:33 +0200 Subject: __builtin_bswap16, 32 and 64 --- mppa_k1c/Asmexpand.ml | 63 +++++++++++++++++++++++++++------------------------ mppa_k1c/CBuiltins.ml | 8 ++----- 2 files changed, 35 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1e5149fd..9c256bd0 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -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 @@ -477,6 +474,12 @@ let expand_builtin_inline name args res = let open Asmvliw in 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) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 235496c5..a91119b1 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -96,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); -- cgit From c5b3084dbb231fd8a97789799fd99d7012d59bed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 16:38:43 +0200 Subject: extraction problems --- mppa_k1c/Asmgen.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index c3588871..e64e3df3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -22,7 +22,8 @@ Require Import Errors String. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := + Compiler.time. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in -- cgit From adc142066720798ca2e6f7709de6fba93559a336 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 17:07:16 +0200 Subject: fix compiling --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e64e3df3..8875a4ac 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -19,11 +19,11 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. Require Import Errors String. +Require Compopts. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := - Compiler.time. +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 := (time "Machblock generation" Machblockgen.transf_program) p in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 5d7bb81f..7388f6da 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -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. unfold time in *. 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. -- cgit From 3e32784577f1a33d0a4cd19d92ccc971996a73ec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 20:10:15 +0200 Subject: fix Focus -> { ... } --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 02d154c7..91be5e2e 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -723,13 +723,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 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. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From a8e2039a772da0fcfd484b7445de8cc093be5d2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 23 Sep 2019 14:17:12 +0200 Subject: is_trapping_op_sound --- mppa_k1c/Op.v | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 7aea2929..92061d04 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1030,6 +1030,34 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_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 *) -- cgit From 4bcba7bdbdaa4afa9dafd5506c980afd711f53f7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Sep 2019 14:20:42 +0200 Subject: (#161) - Fixing vararg bug --- mppa_k1c/Asmexpand.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 9c256bd0..67ef6f52 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -507,8 +507,8 @@ 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 -- cgit From 222cb525b22394077e32fa4e107b033ca2cb6d39 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:20 +0200 Subject: Asmblockgenproof renaming fpok --> ep --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..156354c4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -354,7 +354,7 @@ Record codestate := pbody1: list basic; pbody2: list basic; pctl: option control; - fpok: bool; + ep: bool; rem: list AB.bblock; cur: option bblock }. @@ -379,7 +379,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pbody1 := tbc; pbody2 := (extract_basic tbi); pctl := extract_ctl tbi; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} @@ -400,7 +400,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pbody1 := tbdy; pbody2 := extract_basic tex; pctl := extract_ctl tex; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} (Asmvliw.State rs m) @@ -422,7 +422,7 @@ Lemma transl_blocks_nonil: 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. + 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. @@ -469,7 +469,7 @@ Lemma transl_blocks_distrib: -> 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. + 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. @@ -611,7 +611,7 @@ Proof. 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. + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := Some 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. @@ -1032,7 +1032,7 @@ Lemma step_simu_basic: 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 |} + 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). @@ -1098,7 +1098,7 @@ Proof. (* Opaque loadind. *) (* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep eqn:EPeq. + destruct ep0 eqn:EPeq. (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1253,7 +1253,7 @@ 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; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. @@ -1293,14 +1293,14 @@ Lemma step_simu_body: 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 |} + 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, (fpok cs1). + 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. -- cgit From c229731bdd49255cfb69536ec758eb3004554ce0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:32 +0200 Subject: Tiny clean --- mppa_k1c/Archi.v | 1 - 1 file changed, 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index cdcf58c3..69b32c7c 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -17,7 +17,6 @@ (** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) Require Import ZArith List. -(*From Flocq*) Require Import Binary Bits. Definition ptr64 := true. -- cgit From 541e60e0570b70813c2ace604a1535bb4d79aa2b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 17:29:40 +0200 Subject: Asmblockgenproof : cur rewriting --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 156354c4..1c5ad19c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -356,7 +356,7 @@ Record codestate := pctl: option control; ep: bool; rem: list AB.bblock; - cur: option bblock }. + cur: bblock }. (* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) @@ -381,7 +381,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pctl := extract_ctl tbi; ep := ep; rem := tc; - cur := Some tbb + cur := tbb |} . @@ -402,7 +402,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pctl := extract_ctl tex; ep := ep; rem := tc; - cur := Some tbb |} + cur := tbb |} (Asmvliw.State rs m) . @@ -596,7 +596,7 @@ Theorem match_state_codestate: /\ 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 + /\ cur cs = tbb /\ rem cs = tc /\ pstate cs = abs. Proof. intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. @@ -611,7 +611,7 @@ Proof. 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 := Some tbb |}, fb, f, tbb, tc', ep0. + 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. @@ -719,7 +719,7 @@ Theorem step_simu_control: 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 -> + 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') E0 S'' -> @@ -731,7 +731,7 @@ 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. + inv Hpstate. destruct ctl. + (* MBcall *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. @@ -962,7 +962,7 @@ Proof. econstructor; eauto. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur. + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. (* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) intros (TLB & TLBS). *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. @@ -1446,8 +1446,8 @@ Proof. 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. + 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'). @@ -1472,7 +1472,7 @@ Proof. 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. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. eapply find_bblock_tail; eauto. Qed. -- cgit From 5ffa8534d09272e5f44c51193e74cffdbc2b043c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 15:44:20 +0200 Subject: Icond --- mppa_k1c/Op.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index f9a774e8..ce9a5dcd 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,6 +51,12 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) +Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. +Proof. + generalize comparison_eq int_eq int64_eq. + decide equality. +Defined. + Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From 75326127cbb4d57d435b28651ef65dcd2a0b8ce5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:49:31 +0200 Subject: Fixing fp_is_parent too weak (#165) --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 3605 ++++++++++++++++++++++--------------------- 2 files changed, 1811 insertions(+), 1798 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..bbe24fec 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1111,10 +1111,12 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co 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 chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBstore chunk addr args res => before end. (** This is the naive definition, which is not tail-recursive unlike the other backends *) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1c5ad19c..ad4d2932 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,1797 +1,1808 @@ -(* *********************************************************************) -(* *) -(* 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; - ep: bool; - rem: list AB.bblock; - cur: 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; - ep := ep; - rem := tc; - cur := 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; - ep := ep; - rem := tc; - cur := 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 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. - -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::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 = 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 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. -(* 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; 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. } - 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 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. } - (* 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; ep := (if pheader cs1 then ep 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; 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_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. - { 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. - -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. +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; + ep: bool; + rem: list AB.bblock; + cur: 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; + ep := ep; + rem := tc; + cur := 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; + ep := ep; + rem := tc; + cur := 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 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. + +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::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 = 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 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. +(* 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; 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. } +(* rewrite <- Hheadereq. *) 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'. +(* 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 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. } + (* 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. } + 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. + + - (* 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 := 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; 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_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. + { 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. + +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. -- cgit From 263a8d93cfabcec746c06d4abdcd06a0e8ec6d14 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:54:27 +0200 Subject: Converting mppa_k1c/*.v files to Unix format --- mppa_k1c/Asm.v | 1506 ++++++++++++++++++++++++++--------------------------- mppa_k1c/Asmaux.v | 2 +- 2 files changed, 754 insertions(+), 754 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e27ff40c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +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 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 (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 *) - | 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 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) : 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. +(* *********************************************************************) +(* *) +(* 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 (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 *) + | 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 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) : 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 94b39f4e..891d1068 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -2,4 +2,4 @@ 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 |}. +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. -- cgit From 6d4ec0d398dcc9ec766c3f55ba4edbae63fb6a2f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 15:51:44 +0200 Subject: More elaborate comments + rewriting for easier to understand Asmblockgenproof.v --- mppa_k1c/Asmblockgenproof.v | 234 +++++++++++++++++--------------------------- 1 file changed, 89 insertions(+), 145 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ad4d2932..834e11e1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -47,7 +47,6 @@ 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 -> @@ -65,8 +64,6 @@ Proof. 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. @@ -75,23 +72,7 @@ Proof. 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. +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) Lemma gen_bblocks_label: forall hd bdy ex tbb tc, @@ -113,7 +94,7 @@ Proof. all: inv GENB; simpl; auto. Qed. -Lemma in_dec_transl: +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. @@ -226,7 +207,7 @@ Proof. rewrite H. auto. Qed. -Lemma transl_find_label: +Theorem transl_find_label: forall lbl f tf, transf_function f = OK tf -> match MB.find_label lbl f.(MB.fn_code) with @@ -241,8 +222,8 @@ 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. *) +(** 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, @@ -270,48 +251,47 @@ 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) -> + 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. -(* rewrite transl_code'_transl_code in EQ0. *) - exists x; exists true; split; auto. (* unfold fn_code. *) + exists x; exists true; split; auto. repeat constructor. - - exact transf_function_no_overflow. +- exact transf_function_no_overflow. Qed. (** * Proof of semantic preservation *) -(** Semantic preservation is proved using simulation diagrams +(** Semantic preservation is proved using a complex simulation diagram of the following form. << - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' + 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 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. *) + 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. @@ -349,17 +329,18 @@ Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := (Asmvliw.State rs m'). Record codestate := - Codestate { pstate: state; + Codestate { pstate: state; (**r projection to Asmblock.state *) pheader: list label; - pbody1: list basic; - pbody2: list basic; - pctl: option control; - ep: bool; - rem: list AB.bblock; - cur: bblock }. - -(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) - + 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 @@ -369,7 +350,6 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (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) , @@ -377,7 +357,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := {| pstate := (Asmvliw.State rs0 m0); pheader := (MB.header bb); pbody1 := tbc; - pbody2 := (extract_basic tbi); + pbody2 := extract_basic tbi; pctl := extract_ctl tbi; ep := ep; rem := tc; @@ -385,6 +365,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := |} . +(* 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 @@ -392,7 +373,6 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (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); @@ -406,6 +386,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (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 @@ -417,6 +398,8 @@ Ltac exploreInst := | [ 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 -> @@ -584,6 +567,9 @@ Proof. * 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)) -> @@ -624,7 +610,7 @@ Definition mb_remove_body (bb: MB.bblock) := 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 (Pnop ::g nil) rs2 m2 -> exec_straight tge c rs1 m1 nil rs2 m2. Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. @@ -656,10 +642,9 @@ Lemma nextblock_preserves: Proof. intros. destruct r; try discriminate. subst. Simpl. -(* - subst. Simpl. *) Qed. -Lemma cons3_app {A: Type}: +Remark cons3_app {A: Type}: forall a b c (l: list A), a :: b :: c :: l = (a :: b :: c :: nil) ++ l. Proof. @@ -693,27 +678,11 @@ 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. *) - +(* 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 E0 S'' rs1 m1 tbb tbdy2 tex cs2, + 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) -> @@ -722,7 +691,7 @@ Theorem step_simu_control: 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') E0 S'' -> + 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 @@ -834,7 +803,6 @@ Proof. 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. @@ -853,7 +821,6 @@ Proof. 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. @@ -932,7 +899,7 @@ Proof. 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. @@ -955,7 +922,7 @@ Proof. 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. @@ -963,10 +930,7 @@ Proof. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. -(* 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. *) + 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. @@ -1023,7 +987,8 @@ Proof. all: eauto. Qed. -Lemma step_simu_basic: +(* 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 |} -> @@ -1058,7 +1023,7 @@ Proof. 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. simpl in Hheadereq. + subst. simpl in Hheadereq. eapply match_codestate_intro; eauto. { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } @@ -1084,8 +1049,7 @@ Proof. 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. + subst. eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. eapply agree_undef_regs; eauto with asmgen. @@ -1101,10 +1065,9 @@ Proof. 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 ep0 eqn:EPeq. + (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1119,14 +1082,14 @@ Proof. { 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. + 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 *) + (* 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. @@ -1157,7 +1120,7 @@ Proof. 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. @@ -1175,8 +1138,7 @@ Proof. 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. + 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. @@ -1265,12 +1227,11 @@ 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 := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. -Lemma step_simu_header: +(* Theorem (A) in the diagram, the easiest of all *) +Theorem 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', @@ -1295,7 +1256,8 @@ Proof. simpl. econstructor; eauto. Qed. -Lemma step_simu_body: +(* 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)) -> @@ -1326,23 +1288,6 @@ Proof. 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 -> @@ -1387,7 +1332,8 @@ Proof. contradict H. unfold mbsize. simpl. auto. Qed. -(* Alternative form of step_simulation_bblock, easier to prove *) +(* 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 -> @@ -1436,8 +1382,6 @@ Proof. 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. @@ -1487,7 +1431,7 @@ Proof. eapply find_bblock_tail; eauto. Qed. -Lemma step_simulation_bblock: +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)) -> @@ -1503,12 +1447,7 @@ Proof. - econstructor. Qed. -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. +(** Dealing now with the builtin case *) Definition split (c: MB.code) := match c with @@ -1564,7 +1503,7 @@ Proof. eapply transl_code_at_pc_split_builtin; eauto. Qed. -Lemma step_simulation_builtin: +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 -> @@ -1611,6 +1550,16 @@ 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'), @@ -1665,25 +1614,20 @@ Proof. 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. *) + 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 (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' @@ -1729,7 +1673,6 @@ Local Transparent destroyed_at_function_entry. 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. @@ -1737,6 +1680,7 @@ Local Transparent destroyed_at_function_entry. 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. -- cgit From 72378d9371bc5da342266bcf14231ab568e0f919 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 16:01:30 +0200 Subject: Few minor other changes in proof --- mppa_k1c/Asmblockgenproof.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 834e11e1..bd2dc985 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1621,12 +1621,12 @@ Proof. 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. + { 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. + change (rs2 SP) with sp. eexact P. } intros (rs3 & U & V). assert (EXEC_PROLOGUE: exists rs3', exec_straight_blocks tge tf @@ -1652,7 +1652,7 @@ Proof. } 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). + 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. -- cgit From d4e2f7b715b21efe0d693415ab63dad5a22afa92 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Oct 2019 18:34:30 +0200 Subject: eq_condition already existed --- mppa_k1c/Op.v | 6 ------ 1 file changed, 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index ce9a5dcd..f9a774e8 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,12 +51,6 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) -Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. -Proof. - generalize comparison_eq int_eq int64_eq. - decide equality. -Defined. - Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From e247f20f8fb530bb225ac04f2e1589beaffcb257 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 Oct 2019 18:11:33 +0200 Subject: Un espace en trop --- mppa_k1c/Asmblockgen.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index bbe24fec..abb24327 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1185,7 +1185,7 @@ Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := match lmb with | nil => OK nil - | mb :: lmb => + | mb :: lmb => do lb <- transl_block f mb (if Machblock.header mb then ep else false); do lb' <- transl_blocks f lmb false; OK (lb @@ lb') -- cgit From 8d1b23070baa3c2db69a066dfc097e08bb811eb3 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 15:35:47 +0100 Subject: removing Focus (deprecated) --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index ab7fff74..8da610ad 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -719,13 +719,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 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. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From 4c471a5a7852d02c368101205b34418c0f754b91 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 16:04:03 +0100 Subject: fixing a potential inconsistency from unsafe_coerce Now, unsafe_coerce axioms are clearly consistent (for any interpretation of may-return monads). But, the extraction is still unsafe... --- mppa_k1c/Asmblockdeps.v | 10 ++++++++-- mppa_k1c/abstractbb/Impure/ImpConfig.v | 10 +++++----- 2 files changed, 13 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..8bc1112f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1636,11 +1636,17 @@ 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: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.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. 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. -- cgit From 553714035fc08f9b145b89b3dd7c455f06e917df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Dec 2019 21:39:20 +0100 Subject: finish merge --- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof.v | 29 +++++++++++++++++++---------- 2 files changed, 20 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5825fd04..50637723 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1116,7 +1116,7 @@ Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | MBload chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) | MBstore chunk addr args res => before end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index cdbaf16a..b3e0ee23 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1203,14 +1203,18 @@ Local Transparent destroyed_by_op. 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. + 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. @@ -1226,10 +1230,15 @@ Local Transparent destroyed_by_op. 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 match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + 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. -- cgit From 98764278b804517f733982071da37769816a4833 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Dec 2019 15:12:09 +0100 Subject: Converting Asm.v and Asmblockgenproof.v back to Unix format --- mppa_k1c/Asm.v | 1506 +++++++++---------- mppa_k1c/Asmblockgenproof.v | 3346 +++++++++++++++++++++---------------------- 2 files changed, 2426 insertions(+), 2426 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e37176ef..189e0c76 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +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 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. +(* *********************************************************************) +(* *) +(* 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/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index b3e0ee23..e130df45 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,274 +1,274 @@ -(* *********************************************************************) -(* *) -(* 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. - -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 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. + +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. - + +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. - + 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. - + 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: + +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 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. + repeat constructor. - exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - +Qed. + +(** * Proof of semantic preservation *) + (** Semantic preservation is proved using a complex simulation diagram - of the following form. -<< + of the following form. +<< MB.step ----------------------------------------> header body exit @@ -283,54 +283,54 @@ Qed. | / 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 := + +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; + 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 *) @@ -341,869 +341,869 @@ Record codestate := (* 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; +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; + pctl := extract_ctl tbi; ep := ep; - rem := tc; + 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; +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; + rem := tc; cur := tbb |} - (Asmvliw.State rs m) -. - + (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. - +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. +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. + 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. - + 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 +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; + /\ 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, + 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. - + 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. - + 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: +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 -> + 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) -> + 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 *. + (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. - + 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. - + 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; + 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'. + /\ 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. + 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'. + - (* 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. + 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. } + (* 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. - + 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'. + + 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'. + 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. + 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. + + - (* 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. @@ -1215,406 +1215,406 @@ Local Transparent destroyed_by_op. 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. + } + { + 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. + + 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'. + } + - (* 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. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. - eapply agree_undef_regs; eauto with asmgen. + 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; +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 |}. - + 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. - + 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; + 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. + /\ 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_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. - + 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_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. + (* 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. +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''. + 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. - + 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. - + 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. - + +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. - + 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 @@ -1625,193 +1625,193 @@ Definition measure (s: MB.state) : nat := (* 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 *) +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'). + 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. + 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. + 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. -- cgit From 9937f23871513d4bf77db5b541a93f6327365f1e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Dec 2019 19:08:50 +0100 Subject: begin overlap proofs --- mppa_k1c/Asmblockdeps.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c7cfe43c..2b2627e7 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -22,6 +22,8 @@ Require Import Parallelizability. Require Import Asmvliw Permutation. Require Import Chunks. +Require Import Lia. + Open Scope impure. (** Definition of L *) @@ -208,6 +210,47 @@ Definition store_eval (so: store_op) (l: list value) := | _, _ => None end. +Local Open Scope Z. + +Definition no_overlap_segments l1 h1 l2 h2 := + (h1 <=? l2) || (h2 <=? l1). + +Definition in_segment l h x := + (l <=? x) && (x + (in_segment l2 h2 x) = true -> + (no_overlap_segments l1 h1 l2 h2) = false. +Proof. + unfold in_segment, no_overlap_segments. + intros until x. + intros H1 H2. + destruct (andb_true_iff (l1 <=? x) (x + 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 n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From fd1d1f8c981332afad01b36915bc5b06d4066f70 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Dec 2019 15:24:27 +0100 Subject: some subgoal was proved --- mppa_k1c/Asmblockdeps.v | 67 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 61 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2b2627e7..0f534350 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -244,13 +244,68 @@ Proof. rewrite Z.leb_le. lia. Qed. - -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1', - 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 n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). +Definition no_overlap_chunks + (ofs1 : offset) (chunk1 : memory_chunk) + (ofs2 : offset) (chunk2 : memory_chunk) := + no_overlap_segments (Ptrofs.unsigned ofs1) + ((Ptrofs.unsigned ofs1) + (size_chunk chunk1)) + (Ptrofs.unsigned ofs2) + ((Ptrofs.unsigned ofs2) + (size_chunk chunk2)). + +Definition same_memory (m m' : mem) := + forall chunk block ofs, + (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). + +(* use something like load_store_other *) +Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', + (no_overlap_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2))=true -> + same_memory m0 m0' -> + 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') -> + same_memory m2 m2'. +Proof. + intros until m2'. + intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. + unfold same_memory. + intros rchunk rblock rofs. + unfold no_overlap_chunks in NO_OVERLAP. + unfold no_overlap_segments in NO_OVERLAP. + rewrite orb_true_iff in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + 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. + destruct (eval_offset ofs1) as [ i1 |]; try congruence. + destruct (eval_offset ofs2) as [ i2 |]; try congruence. + unfold Mem.storev in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + inv STORE0. + destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + inv STORE1. + destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + inv STORE0'. + destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + inv STORE1'. + destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. + { admit. + } + { (* read from different base block *) + rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. + rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. + apply SAME. + } +Admitted. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From db03f4f3f90d7eab399177fc3f27ac027c10bc9f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 13:10:01 +0100 Subject: progress in chunks --- mppa_k1c/Asmblockdeps.v | 54 +++++++++---------------------------------------- 1 file changed, 9 insertions(+), 45 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0f534350..c54cc317 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,46 +212,13 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. -Definition no_overlap_segments l1 h1 l2 h2 := - (h1 <=? l2) || (h2 <=? l1). - -Definition in_segment l h x := - (l <=? x) && (x - (in_segment l2 h2 x) = true -> - (no_overlap_segments l1 h1 l2 h2) = false. -Proof. - unfold in_segment, no_overlap_segments. - intros until x. - intros H1 H2. - destruct (andb_true_iff (l1 <=? x) (x + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> same_memory m0 m0' -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> @@ -271,11 +238,7 @@ Proof. intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. unfold same_memory. intros rchunk rblock rofs. - unfold no_overlap_chunks in NO_OVERLAP. - unfold no_overlap_segments in NO_OVERLAP. - rewrite orb_true_iff in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. + unfold disjoint_chunks in NO_OVERLAP. 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. @@ -295,7 +258,8 @@ Proof. destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. inv STORE1'. destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { admit. + { subst rblock. + admit. } { (* read from different base block *) rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. -- cgit From ce3f5cd4afdd5f5794b9c0a7480947b25e3685d0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Dec 2019 08:58:12 +0100 Subject: comment out theorem that cannot be proved --- mppa_k1c/Asmblockdeps.v | 62 ++++++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c54cc317..4d53763c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,6 +212,12 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. +Remark size_chunk_positive: forall chunk, + (size_chunk chunk) > 0. +Proof. + destruct chunk; simpl; lia. +Qed. + Definition disjoint_chunks (ofs1 : offset) (chunk1 : memory_chunk) (ofs2 : offset) (chunk2 : memory_chunk) := @@ -220,56 +226,54 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -Definition same_memory (m m' : mem) := - forall chunk block ofs, - (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). - +(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING (* use something like load_store_other *) Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> - same_memory m0 m0' -> 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') -> - same_memory m2 m2'. + m2 = m2'. Proof. intros until m2'. - intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. - unfold same_memory. - intros rchunk rblock rofs. - unfold disjoint_chunks in NO_OVERLAP. + intros DISJOINT 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. - destruct (eval_offset ofs1) as [ i1 |]; try congruence. - destruct (eval_offset ofs2) as [ i2 |]; try congruence. + 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 (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. inv STORE0. - destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. inv STORE1. - destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. inv STORE0'. - destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. inv STORE1'. - destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { subst rblock. - admit. - } - { (* read from different base block *) - rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. - rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. - apply SAME. - } -Admitted. - + assert (Some m2 = Some m2'). + 2: congruence. + rewrite <- E1. + rewrite <- E1'. + eapply Mem.store_store_other. + { + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + try lia. + } +*) + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From 34518ae5db9ca7c04d9ce5d90261ede3c9d0e550 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 14:45:56 +0100 Subject: swap stores at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4d53763c..759b4396 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -218,6 +218,12 @@ 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) := @@ -226,18 +232,20 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING -(* use something like load_store_other *) -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', +Definition small_offset_threshold := 18446744073709551608. + +Lemma store_swap : 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 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 STORE0 STORE1 STORE0' STORE1'. + 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. @@ -261,18 +269,24 @@ Proof. rewrite <- E1. rewrite <- E1'. eapply Mem.store_store_other. - { - right. - pose proof (size_chunk_positive (store_chunk n1)). - pose proof (size_chunk_positive (store_chunk n2)). - destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; - unfold Intv.empty in DIS; simpl in DIS. - 1, 2: lia. - destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + 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; - try lia. - } -*) + change Ptrofs.modulus with 18446744073709551616 in *; + lia. +Qed. Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with -- cgit From 26775340b173fd631e850f0a553ddab25c934fbc Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:03:12 +0100 Subject: Stub for opcode heuristic --- mppa_k1c/DuplicateOpcodeHeuristic.ml | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 mppa_k1c/DuplicateOpcodeHeuristic.ml (limited to 'mppa_k1c') diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..fe9307f2 --- /dev/null +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,4 @@ +(* open Camlcoq *) +(* open Op *) + +let opcode_heuristic code cond ifso ifnot preferred = () -- cgit From dc7ba7bf86828da813e60d60dc9627cbd6ddcf0e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 16:45:14 +0100 Subject: swap load and store at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 759b4396..2cdf9499 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -234,7 +234,8 @@ Definition disjoint_chunks Definition small_offset_threshold := 18446744073709551608. -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', +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 -> @@ -288,6 +289,57 @@ Proof. 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 in STORE0; 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 -- cgit From aed1bf936b69464f99a92133a43d51664295d780 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:55:40 +0100 Subject: Opcode heuristic done for K1c --- mppa_k1c/DuplicateOpcodeHeuristic.ml | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index fe9307f2..690553ce 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -1,4 +1,32 @@ (* open Camlcoq *) -(* open Op *) +open Op +open Integers -let opcode_heuristic code cond ifso ifnot preferred = () +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = + let decision = 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 + in match decision with + | Some b -> (preferred := b; raise HeuristicSucceeded) + | None -> () -- cgit From 27767971a256b97ee75deab19a01d575ee01a6e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 Jan 2020 15:38:45 +0100 Subject: Fixing issue with "destruct ... in ..." tactics with Coq 8.8 --- mppa_k1c/Asmblockdeps.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2cdf9499..584f2339 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -257,13 +257,13 @@ Proof. unfold Mem.storev in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. inv STORE0. - destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. + destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. inv STORE1. - destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. + destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. inv STORE0'. - destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. + destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. inv STORE1'. assert (Some m2 = Some m2'). 2: congruence. @@ -310,7 +310,7 @@ Proof. unfold eval_offset in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0; try congruence. inv STORE0. assert ( (Mem.load (load_chunk n2) m1 wblock -- cgit From ae8c21b078fda638b706d157e1b9a16e4bcc4ab7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 11:49:05 +0100 Subject: Breaking the prologue to satisfy resource constraints --- mppa_k1c/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d52bd485..8ab10bc5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -514,8 +514,8 @@ let expand_instruction instr = 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) -> -- cgit From 56240b6f831e3aeca751c718dace1fd42724749d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:06:46 +0100 Subject: Fixed reservation tables --- mppa_k1c/PostpassSchedulingOracle.ml | 90 ++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 44 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index cdda0e6d..a97fda83 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,7 +442,7 @@ 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"] +let resource_names = ["ISSUE"; "TINY"; "LITE"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "NOP"] let rec find_index elt l = match l with @@ -457,31 +457,24 @@ let resource_bound resource : int = | "ISSUE" -> 8 | "TINY" -> 4 | "LITE" -> 2 - | "ALU" -> 1 + | "FULL" -> 1 | "LSU" -> 1 | "MAU" -> 1 | "BCU" -> 1 - | "ACC" -> 1 - | "DATA" -> 1 | "TCA" -> 1 - | "BRE" -> 1 - | "BRO" -> 1 + | "AUXR" -> 1 + | "AUXW" -> 1 + | "CRRP" -> 1 + | "CRWL" -> 1 + | "CRWH" -> 1 | "NOP" -> 4 | _ -> raise Not_found 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 + | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with @@ -496,24 +489,20 @@ let alu_lite_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 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 - 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 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 + | "ISSUE" -> 1 | "TINY" -> 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 + | "ISSUE" -> 2 | "TINY" -> 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 + | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with @@ -524,30 +513,43 @@ 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 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 + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 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_auxw : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 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_auxw_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 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_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 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 mau : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 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 mau_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 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 + in Array.of_list (List.map resmap resource_names) + + (** Real instructions *) exception InvalidEncoding @@ -612,13 +614,13 @@ 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 -- cgit From 4d0cc4318d6f46d9575ff7ebb1b74d8d8632ebb1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:18:53 +0100 Subject: Using Ocaml type instead of string to identify resources --- mppa_k1c/PostpassSchedulingOracle.ml | 71 ++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 35 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a97fda83..49cece02 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,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"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "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 @@ -454,99 +456,98 @@ let resource_id resource : int = find_index resource resource_names let resource_bound resource : int = match resource with - | "ISSUE" -> 8 - | "TINY" -> 4 - | "LITE" -> 2 - | "FULL" -> 1 - | "LSU" -> 1 - | "MAU" -> 1 - | "BCU" -> 1 - | "TCA" -> 1 - | "AUXR" -> 1 - | "AUXW" -> 1 - | "CRRP" -> 1 - | "CRWL" -> 1 - | "CRWH" -> 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_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 + | 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_lite_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | 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 alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 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 + | Rissue -> 2 | Rtiny -> 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 + | 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_auxr : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 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 + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 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 + | 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 - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -- cgit From fadf090fcc33d9d5aabde1cb1f2c5116302427a4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 14:30:28 +0100 Subject: Fixing maddw and maddd resource tables --- mppa_k1c/PostpassSchedulingOracle.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 49cece02..686979a6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -550,6 +550,17 @@ 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 *) @@ -602,10 +613,16 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw| Maddw | Msbfw -> (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 | Msbfd -> (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 -- cgit From aec490a064af1cdbcc8ac70a9b5a2c882bea6b55 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 16:26:05 +0100 Subject: Moved some theorems --- mppa_k1c/Asmblock.v | 25 +++++++ mppa_k1c/Asmblockgenproof.v | 13 ---- mppa_k1c/Asmblockgenproof0.v | 139 ++++++++++++++++++++----------------- mppa_k1c/PostpassSchedulingproof.v | 37 ---------- 4 files changed, 101 insertions(+), 113 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 91e5ac89..cce180ac 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -294,6 +294,31 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. + +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. + +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. + (** 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. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e130df45..220ae08b 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1353,19 +1353,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. 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 -> diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 07c445e2..d2450a9a 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -752,6 +752,82 @@ Proof. intros. destruct H. auto. 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. + +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. + +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. @@ -880,69 +956,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: 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. - Lemma exec_straight_pc: forall c c' rs1 m1 rs2 m2, exec_straight c rs1 m1 c' rs2 m2 -> diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 867c10c5..cdf8829f 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,43 +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'. -- cgit From b748b38c8b3a998f018477d7375ae16997318769 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:30:07 +0100 Subject: Removing from Asmblockgenproof0 architecture specific definitions --- mppa_k1c/Asmblock.v | 13 ++++ mppa_k1c/Asmblockdeps.v | 10 +-- mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof0.v | 124 ++---------------------------------- mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmblockprops.v | 126 +++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassScheduling.v | 2 +- mppa_k1c/PostpassSchedulingproof.v | 2 +- 8 files changed, 152 insertions(+), 129 deletions(-) create mode 100644 mppa_k1c/Asmblockprops.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cce180ac..a05d4726 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -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 *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 584f2339..02f9141b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -7,7 +7,7 @@ Require Import AST. Require Import Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import Values. Require Import Globalenvs. Require Import Memory. @@ -1429,7 +1429,7 @@ 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. @@ -1787,7 +1787,7 @@ Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := 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, 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. @@ -1803,7 +1803,7 @@ Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := | None => false end. -Theorem pure_bblock_simu_test_correct verb p1 p2 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. unfold pure_bblock_simu_test. destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. @@ -1813,7 +1813,7 @@ Qed. Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Lemma bblock_simub_correct p1 p2 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. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 220ae08b..1a427112 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -16,7 +16,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 Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. Require Import Axioms. Module MB := Machblock. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index d2450a9a..940c6563 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -22,16 +22,10 @@ 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'. @@ -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') -> @@ -294,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). @@ -752,69 +699,6 @@ Proof. intros. destruct H. auto. 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. - -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. - Lemma exec_body_pc: forall ge l rs1 m1 rs2 m2, exec_body ge l rs1 m1 = Next rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c0a05ab3..ecb4629b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -20,7 +20,7 @@ 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. (** Decomposition of integer constants. *) diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v new file mode 100644 index 00000000..7f6e33db --- /dev/null +++ b/mppa_k1c/Asmblockprops.v @@ -0,0 +1,126 @@ +(** 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. + +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. + +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. \ No newline at end of file diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 8b6de1e2..31180cea 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -12,7 +12,7 @@ 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. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index cdf8829f..f1166a38 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. -- cgit From c9ad4b36bb969439d554784f553b7da01e0ba04b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:59:02 +0100 Subject: Moving Asmblockgenproof0 to mppa_k1c/lib/ --- mppa_k1c/Asmblockgenproof0.v | 967 --------------------------------------- mppa_k1c/lib/Asmblockgenproof0.v | 967 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 967 insertions(+), 967 deletions(-) delete mode 100644 mppa_k1c/Asmblockgenproof0.v create mode 100644 mppa_k1c/lib/Asmblockgenproof0.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v deleted file mode 100644 index 940c6563..00000000 --- a/mppa_k1c/Asmblockgenproof0.v +++ /dev/null @@ -1,967 +0,0 @@ -(** * "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. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -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:=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. -Qed. - -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. -Qed. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -Lemma undef_regs_other: - forall r rl rs, - (forall r', In r' rl -> r <> r') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree 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 Mach.undef_regs_other; 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 -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -Qed. - -Lemma agree_undef_caller_save_regs: - forall ms sp rs, - agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). -Proof. - 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). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -Hypothesis transf_function_len: - forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. - - -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. 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). - monadInv TR2. - assert (TL3: is_tail x0 (fn_blocks tf)). - { apply is_tail_trans with tc1; auto. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -Qed. - -End RETADDR_EXISTS. - -(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - 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]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -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. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; 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 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -Qed. - -(** Linking exec_straight with exec_straight_blocks *) - -Lemma exec_straight_pc: - forall c c' rs1 m1 rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma regset_same_assign (rs: regset) r: - rs # r <- (rs r) = rs. -Proof. - apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. -Qed. - -Lemma exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. rewrite regset_same_assign. auto. - 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. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v new file mode 100644 index 00000000..940c6563 --- /dev/null +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -0,0 +1,967 @@ +(** * "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. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +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:=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. +Qed. + +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. +Qed. + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree 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 Mach.undef_regs_other; 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 -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). +Proof. + 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). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +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. 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). + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + 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]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +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. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; 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 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma regset_same_assign (rs: regset) r: + rs # r <- (rs r) = rs. +Proof. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. rewrite regset_same_assign. auto. + 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. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. -- cgit From e882ee6daa01579bf717b43b55091c859ed75661 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 11 Feb 2020 11:28:38 +0100 Subject: Moving some arch specific theorems from PSproof to Asmblockprops --- mppa_k1c/Asmblockprops.v | 219 ++++++++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingproof.v | 218 ------------------------------------ 2 files changed, 218 insertions(+), 219 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v index 7f6e33db..3c6ba534 100644 --- a/mppa_k1c/Asmblockprops.v +++ b/mppa_k1c/Asmblockprops.v @@ -6,6 +6,7 @@ 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, @@ -72,6 +73,8 @@ Ltac Simplif := 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 -> @@ -123,4 +126,218 @@ Proof. - destruct rs; try discriminate. inv H1. Simpl. - destruct rd; try discriminate. inv H1; Simpl. - reflexivity. -Qed. \ No newline at end of file +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/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f1166a38..fbb06c9b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,25 +30,6 @@ Proof. intros. eapply match_transform_partial_program; 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). @@ -58,197 +39,6 @@ Proof. - repeat (rewrite Pregmap.gso); 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. - -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 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. - Lemma exec_body_pc_var: forall l ge rs m rs' m' v, exec_body ge l rs m = Next rs' m' -> @@ -745,12 +535,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. @@ -761,7 +547,6 @@ 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. @@ -883,9 +668,6 @@ Qed. End PRESERVATION_ASMVLIW. - - - Section PRESERVATION. Variables prog tprog: program. -- cgit