diff options
Diffstat (limited to 'arm')
| -rw-r--r-- | arm/Asmgen.v | 554 | ||||
| -rw-r--r-- | arm/Asmgenproof.v | 1246 | ||||
| -rw-r--r-- | arm/Asmgenproof1.v | 1507 | ||||
| -rw-r--r-- | arm/Asmgenretaddr.v | 201 | ||||
| -rw-r--r-- | arm/Constprop.v | 1254 | ||||
| -rw-r--r-- | arm/Constpropproof.v | 970 | ||||
| -rw-r--r-- | arm/Machregs.v | 80 | ||||
| -rw-r--r-- | arm/Op.v | 1007 | ||||
| -rw-r--r-- | arm/Selection.v | 1394 | ||||
| -rw-r--r-- | arm/Selectionproof.v | 1475 | ||||
| -rw-r--r-- | arm/linux/Conventions.v | 858 | ||||
| -rw-r--r-- | arm/linux/Stacklayout.v | 79 |
12 files changed, 10625 insertions, 0 deletions
diff --git a/arm/Asmgen.v b/arm/Asmgen.v new file mode 100644 index 0000000..a360bde --- /dev/null +++ b/arm/Asmgen.v @@ -0,0 +1,554 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Translation from Mach to ARM. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import Asm. + +(** Translation of the LTL/Linear/Mach view of machine registers + to the ARM view. ARM has two different types for registers + (integer and float) while LTL et al have only one. The + [ireg_of] and [freg_of] are therefore partial in principle. + To keep things simpler, we make them return nonsensical + results when applied to a LTL register of the wrong type. + The proof in [ARMgenproof] will show that this never happens. + + Note that no LTL register maps to [IR14]. + This register is reserved as temporary, to be used + by the generated ARM code. *) + +Definition ireg_of (r: mreg) : ireg := + match r with + | R0 => IR0 | R1 => IR1 | R2 => IR2 | R3 => IR3 + | R4 => IR4 | R5 => IR5 | R6 => IR6 | R7 => IR7 + | R8 => IR8 | R9 => IR9 | R11 => IR11 + | IT1 => IR10 | IT2 => IR12 + | _ => IR0 (* should not happen *) + end. + +Definition freg_of (r: mreg) : freg := + match r with + | F0 => FR0 | F1 => FR1 + | F4 => FR4 | F5 => FR5 | F6 => FR6 | F7 => FR7 + | FT1 => FR2 | FT2 => FR3 + | _ => FR0 (* should not happen *) + end. + +(** Recognition of integer immediate arguments. +- For arithmetic operations, immediates are + 8-bit quantities zero-extended and rotated right by 0, 2, 4, ... 30 bits. +- For memory accesses of type [Mint32], immediate offsets are + 12-bit quantities plus a sign bit. +- For other memory accesses, immediate offsets are + 8-bit quantities plus a sign bit. *) + +Fixpoint is_immed_arith_aux (n: nat) (x msk: int) {struct n}: bool := + match n with + | O => false + | Datatypes.S n' => + Int.eq (Int.and x (Int.not msk)) Int.zero || + is_immed_arith_aux n' x (Int.ror msk (Int.repr 2)) + end. + +Definition is_immed_arith (x: int) : bool := + is_immed_arith_aux 16%nat x (Int.repr 255). + +Definition is_immed_mem_word (x: int) : bool := + Int.lt x (Int.repr 4096) && Int.lt (Int.repr (-4096)) x. + +Definition is_immed_mem_small (x: int) : bool := + Int.lt x (Int.repr 256) && Int.lt (Int.repr (-256)) x. + +Definition is_immed_mem_float (x: int) : bool := + Int.eq (Int.and x (Int.repr 3)) Int.zero + && Int.lt x (Int.repr 1024) && Int.lt (Int.repr (-1024)) x. + +(** Smart constructor for integer immediate arguments. *) + +Definition loadimm (r: ireg) (n: int) (k: code) := + if is_immed_arith n then + Pmov r (SOimm n) :: k + else if is_immed_arith (Int.not n) then + Pmvn r (SOimm (Int.not n)) :: k + else (* could be much improved! *) + Pmov r (SOimm (Int.and n (Int.repr 255))) :: + Porr r r (SOimm (Int.and n (Int.repr 65280))) :: + Porr r r (SOimm (Int.and n (Int.repr 16711680))) :: + Porr r r (SOimm (Int.and n (Int.repr 4278190080))) :: + k. + +Definition addimm (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + Padd r1 r2 (SOimm n) :: k + else if is_immed_arith (Int.neg n) then + Psub r1 r2 (SOimm (Int.neg n)) :: k + else + Padd r1 r2 (SOimm (Int.and n (Int.repr 255))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 65280))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 16711680))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 4278190080))) :: + k. + +Definition andimm (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + Pand r1 r2 (SOimm n) :: k + else if is_immed_arith (Int.not n) then + Pbic r1 r2 (SOimm (Int.not n)) :: k + else + loadimm IR14 n (Pand r1 r2 (SOreg IR14) :: k). + +Definition makeimm (instr: ireg -> ireg -> shift_op -> instruction) + (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + instr r1 r2 (SOimm n) :: k + else + loadimm IR14 n (instr r1 r2 (SOreg IR14) :: k). + +(** Translation of a shift immediate operation (type [Op.shift]) *) + +Definition transl_shift (s: shift) (r: ireg) : shift_op := + match s with + | Slsl n => SOlslimm r (s_amount n) + | Slsr n => SOlsrimm r (s_amount n) + | Sasr n => SOasrimm r (s_amount n) + | Sror n => SOrorimm r (s_amount n) + end. + +(** Translation of a condition. Prepends to [k] the instructions + that evaluate the condition and leave its boolean result in one of + the bits of the condition register. The bit in question is + determined by the [crbit_for_cond] function. *) + +Definition transl_cond + (cond: condition) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Ccompu c, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Ccompshift c s, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Ccompushift c s, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Ccompimm c n, a1 :: nil => + if is_immed_arith n then + Pcmp (ireg_of a1) (SOimm n) :: k + else + loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k) + | Ccompuimm c n, a1 :: nil => + if is_immed_arith n then + Pcmp (ireg_of a1) (SOimm n) :: k + else + loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k) + | Ccompf cmp, a1 :: a2 :: nil => + Pcmf (freg_of a1) (freg_of a2) :: k + | Cnotcompf cmp, a1 :: a2 :: nil => + Pcmf (freg_of a1) (freg_of a2) :: k + | _, _ => + k (**r never happens for well-typed code *) + end. + +Definition crbit_for_signed_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRlt + | Cle => CRle + | Cgt => CRgt + | Cge => CRge + end. + +Definition crbit_for_unsigned_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRlo + | Cle => CRls + | Cgt => CRhi + | Cge => CRhs + end. + +Definition crbit_for_float_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRmi + | Cle => CRls + | Cgt => CRgt + | Cge => CRge + end. + +Definition crbit_for_float_not_cmp (cmp: comparison) := + match cmp with + | Ceq => CRne + | Cne => CReq + | Clt => CRpl + | Cle => CRhi + | Cgt => CRle + | Cge => CRlt + end. + +Definition crbit_for_cond (cond: condition) := + match cond with + | Ccomp cmp => crbit_for_signed_cmp cmp + | Ccompu cmp => crbit_for_unsigned_cmp cmp + | Ccompshift cmp s => crbit_for_signed_cmp cmp + | Ccompushift cmp s => crbit_for_unsigned_cmp cmp + | Ccompimm cmp n => crbit_for_signed_cmp cmp + | Ccompuimm cmp n => crbit_for_unsigned_cmp cmp + | Ccompf cmp => crbit_for_float_cmp cmp + | Cnotcompf cmp => crbit_for_float_not_cmp cmp + end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (r: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match mreg_type a1 with + | Tint => Pmov (ireg_of r) (SOreg (ireg_of a1)) :: k + | Tfloat => Pmvfd (freg_of r) (freg_of a1) :: k + end + | Ointconst n, nil => + loadimm (ireg_of r) n k + | Ofloatconst f, nil => + Plifd (freg_of r) f :: k + | Oaddrsymbol s ofs, nil => + Ploadsymbol (ireg_of r) s ofs :: k + | Oaddrstack n, nil => + addimm (ireg_of r) IR13 n k + | Ocast8signed, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 24)) :: + Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 24)) :: k + | Ocast8unsigned, a1 :: nil => + Pand (ireg_of r) (ireg_of a1) (SOimm (Int.repr 255)) :: k + | Ocast16signed, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: + Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 16)) :: k + | Ocast16unsigned, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: + Pmov (ireg_of r) (SOlsrimm (ireg_of r) (Int.repr 16)) :: k + | Oadd, a1 :: a2 :: nil => + Padd (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oaddshift s, a1 :: a2 :: nil => + Padd (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oaddimm n, a1 :: nil => + addimm (ireg_of r) (ireg_of a1) n k + | Osub, a1 :: a2 :: nil => + Psub (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Osubshift s, a1 :: a2 :: nil => + Psub (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Orsubshift s, a1 :: a2 :: nil => + Prsb (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Orsubimm n, a1 :: nil => + makeimm Prsb (ireg_of r) (ireg_of a1) n k + | Omul, a1 :: a2 :: nil => + if ireg_eq (ireg_of r) (ireg_of a1) + || ireg_eq (ireg_of r) (ireg_of a2) + then Pmul IR14 (ireg_of a1) (ireg_of a2) :: Pmov (ireg_of r) (SOreg IR14) :: k + else Pmul (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Odiv, a1 :: a2 :: nil => + Psdiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Odivu, a1 :: a2 :: nil => + Pudiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oand, a1 :: a2 :: nil => + Pand (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oandshift s, a1 :: a2 :: nil => + Pand (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oandimm n, a1 :: nil => + andimm (ireg_of r) (ireg_of a1) n k + | Oor, a1 :: a2 :: nil => + Porr (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oorshift s, a1 :: a2 :: nil => + Porr (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oorimm n, a1 :: nil => + makeimm Porr (ireg_of r) (ireg_of a1) n k + | Oxor, a1 :: a2 :: nil => + Peor (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oxorshift s, a1 :: a2 :: nil => + Peor (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oxorimm n, a1 :: nil => + makeimm Peor (ireg_of r) (ireg_of a1) n k + | Obic, a1 :: a2 :: nil => + Pbic (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Obicshift s, a1 :: a2 :: nil => + Pbic (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Onot, a1 :: nil => + Pmvn (ireg_of r) (SOreg (ireg_of a1)) :: k + | Onotshift s, a1 :: nil => + Pmvn (ireg_of r) (transl_shift s (ireg_of a1)) :: k + | Oshl, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOlslreg (ireg_of a1) (ireg_of a2)) :: k + | Oshr, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOasrreg (ireg_of a1) (ireg_of a2)) :: k + | Oshru, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOlsrreg (ireg_of a1) (ireg_of a2)) :: k + | Oshift s, a1 :: nil => + Pmov (ireg_of r) (transl_shift s (ireg_of a1)) :: k + | Oshrximm n, a1 :: nil => + Pcmp (ireg_of a1) (SOimm Int.zero) :: + addimm IR14 (ireg_of a1) (Int.sub (Int.shl Int.one n) Int.one) + (Pmovc CRge IR14 (SOreg (ireg_of a1)) :: + Pmov (ireg_of r) (SOasrimm IR14 n) :: k) + | Onegf, a1 :: nil => + Pmnfd (freg_of r) (freg_of a1) :: k + | Oabsf, a1 :: nil => + Pabsd (freg_of r) (freg_of a1) :: k + | Oaddf, a1 :: a2 :: nil => + Padfd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Osubf, a1 :: a2 :: nil => + Psufd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Omulf, a1 :: a2 :: nil => + Pmufd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Odivf, a1 :: a2 :: nil => + Pdvfd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Osingleoffloat, a1 :: nil => + Pmvfs (freg_of r) (freg_of a1) :: k + | Ointoffloat, a1 :: nil => + Pfixz (ireg_of r) (freg_of a1) :: k + | Ointuoffloat, a1 :: nil => + Pfixzu (ireg_of r) (freg_of a1) :: k + | Ofloatofint, a1 :: nil => + Pfltd (freg_of r) (ireg_of a1) :: k + | Ofloatofintu, a1 :: nil => + Pfltud (freg_of r) (ireg_of a1) :: k + | Ocmp cmp, _ => + transl_cond cmp args + (Pmov (ireg_of r) (SOimm Int.zero) :: + Pmovc (crbit_for_cond cmp) (ireg_of r) (SOimm Int.one) :: + k) + | _, _ => + k (**r never happens for well-typed code *) + end. + +(** Common code to translate [Mload] and [Mstore] instructions. *) + +Definition transl_shift_addr (s: shift) (r: ireg) : shift_addr := + match s with + | Slsl n => SAlsl r (s_amount n) + | Slsr n => SAlsr r (s_amount n) + | Sasr n => SAasr r (s_amount n) + | Sror n => SAror r (s_amount n) + end. + +Definition transl_load_store + (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + (addr: addressing) (args: list mreg) (k: code) : code := + match addr, args with + | Aindexed n, a1 :: nil => + if is_immed n then + mk_instr_imm (ireg_of a1) n :: k + else + addimm IR14 (ireg_of a1) n + (mk_instr_imm IR14 Int.zero :: k) + | Aindexed2, a1 :: a2 :: nil => + match mk_instr_gen with + | Some f => + f (ireg_of a1) (SAreg (ireg_of a2)) :: k + | None => + Padd IR14 (ireg_of a1) (SOreg (ireg_of a2)) :: + mk_instr_imm IR14 Int.zero :: k + end + | Aindexed2shift s, a1 :: a2 :: nil => + match mk_instr_gen with + | Some f => + f (ireg_of a1) (transl_shift_addr s (ireg_of a2)) :: k + | None => + Padd IR14 (ireg_of a1) (transl_shift s (ireg_of a2)) :: + mk_instr_imm IR14 Int.zero :: k + end + | Ainstack n, nil => + if is_immed n then + mk_instr_imm IR13 n :: k + else + addimm IR14 IR13 n + (mk_instr_imm IR14 Int.zero :: k) + | _, _ => + (* should not happen *) k + end. + +Definition transl_load_store_int + (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) (addr: addressing) (args: list mreg) (k: code) := + transl_load_store + (fun r n => mk_instr (ireg_of rd) r (SAimm n)) + (Some (mk_instr (ireg_of rd))) + is_immed addr args k. + +Definition transl_load_store_float + (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) (addr: addressing) (args: list mreg) (k: code) := + transl_load_store + (mk_instr (freg_of rd)) + None + is_immed addr args k. + +Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) := + if is_immed_mem_word ofs then + Pldr dst base (SAimm ofs) :: k + else + addimm IR14 base ofs + (Pldr dst IR14 (SAimm Int.zero) :: k). + +Definition loadind_float (base: ireg) (ofs: int) (dst: freg) (k: code) := + if is_immed_mem_float ofs then + Pldfd dst base ofs :: k + else + addimm IR14 base ofs + (Pldfd dst IR14 Int.zero :: k). + +Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := + match ty with + | Tint => loadind_int base ofs (ireg_of dst) k + | Tfloat => loadind_float base ofs (freg_of dst) k + end. + +Definition storeind_int (src: ireg) (base: ireg) (ofs: int) (k: code) := + if is_immed_mem_word ofs then + Pstr src base (SAimm ofs) :: k + else + addimm IR14 base ofs + (Pstr src IR14 (SAimm Int.zero) :: k). + +Definition storeind_float (src: freg) (base: ireg) (ofs: int) (k: code) := + if is_immed_mem_float ofs then + Pstfd src base ofs :: k + else + addimm IR14 base ofs + (Pstfd src IR14 Int.zero :: k). + +Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := + match ty with + | Tint => storeind_int (ireg_of src) base ofs k + | Tfloat => storeind_float (freg_of src) base ofs k + end. + +(** Translation of a Mach instruction. *) + +Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := + match i with + | Mgetstack ofs ty dst => + loadind IR13 ofs ty dst k + | Msetstack src ofs ty => + storeind src IR13 ofs ty k + | Mgetparam ofs ty dst => + loadind_int IR13 f.(fn_link_ofs) IR14 (loadind IR14 ofs ty dst k) + | Mop op args res => + transl_op op args res k + | Mload chunk addr args dst => + match chunk with + | Mint8signed => + transl_load_store_int Pldrsb is_immed_mem_small dst addr args k + | Mint8unsigned => + transl_load_store_int Pldrb is_immed_mem_small dst addr args k + | Mint16signed => + transl_load_store_int Pldrsh is_immed_mem_small dst addr args k + | Mint16unsigned => + transl_load_store_int Pldrh is_immed_mem_small dst addr args k + | Mint32 => + transl_load_store_int Pldr is_immed_mem_word dst addr args k + | Mfloat32 => + transl_load_store_float Pldfs is_immed_mem_float dst addr args k + | Mfloat64 => + transl_load_store_float Pldfd is_immed_mem_float dst addr args k + end + | Mstore chunk addr args src => + match chunk with + | Mint8signed => + transl_load_store_int Pstrb is_immed_mem_small src addr args k + | Mint8unsigned => + transl_load_store_int Pstrb is_immed_mem_small src addr args k + | Mint16signed => + transl_load_store_int Pstrh is_immed_mem_small src addr args k + | Mint16unsigned => + transl_load_store_int Pstrh is_immed_mem_small src addr args k + | Mint32 => + transl_load_store_int Pstr is_immed_mem_word src addr args k + | Mfloat32 => + transl_load_store_float Pstfs is_immed_mem_float src addr args k + | Mfloat64 => + transl_load_store_float Pstfd is_immed_mem_float src addr args k + end + | Mcall sig (inl r) => + Pblreg (ireg_of r) :: k + | Mcall sig (inr symb) => + Pblsymb symb :: k + | Mtailcall sig (inl r) => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbreg (ireg_of r) :: k) + | Mtailcall sig (inr symb) => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbsymb symb :: k) + | Malloc => + Pallocblock :: k + | Mlabel lbl => + Plabel lbl :: k + | Mgoto lbl => + Pb lbl :: k + | Mcond cond args lbl => + transl_cond cond args (Pbc (crbit_for_cond cond) lbl :: k) + | Mreturn => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbreg IR14 :: k) + end. + +Definition transl_code (f: Mach.function) (il: list Mach.instruction) := + List.fold_right (transl_instr f) nil il. + +(** 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) := + Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) :: + transl_code f f.(fn_code). + +Fixpoint code_size (c: code) : Z := + match c with + | nil => 0 + | instr :: c' => code_size c' + 1 + end. + +Open Local Scope string_scope. + +Definition transf_function (f: Mach.function) : res Asm.code := + let c := transl_function f in + if zlt Int.max_unsigned (code_size c) + then Errors.Error (msg "code size exceeded") + else Errors.OK c. + +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/arm/Asmgenproof.v b/arm/Asmgenproof.v new file mode 100644 index 0000000..69a82de --- /dev/null +++ b/arm/Asmgenproof.v @@ -0,0 +1,1246 @@ +(* *********************************************************************) +(* *) +(* 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 ARM code generation: main proof. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import Machconcr. +Require Import Machtyping. +Require Import Asm. +Require Import Asmgen. +Require Import Asmgenretaddr. +Require Import Asmgenproof1. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: transf_program prog = Errors.OK 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. + intros. unfold ge, tge. + apply Genv.find_symbol_transf_partial with transf_fundef. + exact TRANSF. +Qed. + +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 = Errors.OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). + +Lemma functions_transl: + forall f b, + Genv.find_funct_ptr ge b = Some (Internal f) -> + Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). +Proof. + intros. + destruct (functions_translated _ _ H) as [tf [A B]]. + rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. + case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. + congruence. intro. inv B0. auto. +Qed. + +Lemma functions_transl_no_overflow: + forall b f, + Genv.find_funct_ptr ge b = Some (Internal f) -> + code_size (transl_function f) <= Int.max_unsigned. +Proof. + intros. + destruct (functions_translated _ _ H) as [tf [A B]]. + generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. + case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. + congruence. intro; omega. +Qed. + +(** * Properties of control flow *) + +Lemma find_instr_in: + forall c pos i, + find_instr pos c = Some i -> In i c. +Proof. + induction c; simpl. intros; discriminate. + intros until i. case (zeq pos 0); intros. + left; congruence. right; eauto. +Qed. + +Lemma find_instr_tail: + forall c1 i c2 pos, + code_tail pos c1 (i :: c2) -> + find_instr pos c1 = Some i. +Proof. + induction c1; simpl; intros. + inv H. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction. + inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega. + eauto. +Qed. + +Remark code_size_pos: + forall fn, code_size fn >= 0. +Proof. + induction fn; simpl; omega. +Qed. + +Remark code_tail_bounds: + forall fn ofs i c, + code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. +Proof. + assert (forall ofs fn c, code_tail ofs fn c -> + forall i c', c = i :: c' -> 0 <= ofs < code_size fn). + induction 1; intros; simpl. + rewrite H. simpl. generalize (code_size_pos c'). omega. + generalize (IHcode_tail _ _ H0). omega. + eauto. +Qed. + +Lemma code_tail_next: + forall fn ofs i c, + code_tail ofs fn (i :: c) -> + code_tail (ofs + 1) fn c. +Proof. + assert (forall ofs fn c, code_tail ofs fn c -> + forall i c', c = i :: c' -> code_tail (ofs + 1) fn c'). + induction 1; intros. + subst c. constructor. constructor. + constructor. eauto. + eauto. +Qed. + +Lemma code_tail_next_int: + forall fn ofs i c, + code_size fn <= Int.max_unsigned -> + code_tail (Int.unsigned ofs) fn (i :: c) -> + code_tail (Int.unsigned (Int.add ofs Int.one)) fn c. +Proof. + intros. rewrite Int.add_unsigned. + change (Int.unsigned Int.one) with 1. + rewrite Int.unsigned_repr. apply code_tail_next with i; auto. + generalize (code_tail_bounds _ _ _ _ H0). omega. +Qed. + +(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points + within the ARM code generated by translating Mach function [fn], + and [c] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop := + transl_code_at_pc_intro: + forall b ofs f c, + Genv.find_funct_ptr ge b = Some (Internal f) -> + code_tail (Int.unsigned ofs) (transl_function f) (transl_code f c) -> + transl_code_at_pc (Vptr b ofs) b f c. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight]) correspond to correct ARM executions + (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *) + +Lemma exec_straight_steps_1: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_instr_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_instr_tail. eauto. + apply IHexec_straight with b (Int.add ofs Int.one). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int with i; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Int.unsigned ofs') fn c'. +Proof. + induction 1; intros. + exists (Int.add ofs Int.one). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int with i1; auto. + apply IHexec_straight with (Int.add ofs Int.one). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int with i; auto. +Qed. + +Lemma exec_straight_exec: + forall fb f c c' rs m rs' m', + transl_code_at_pc (rs PC) fb f c -> + exec_straight tge (transl_function f) + (transl_code f c) rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inversion H. subst. + eapply exec_straight_steps_1; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c c' rs m rs' m', + transl_code_at_pc (rs PC) fb f c -> + exec_straight tge (transl_function f) + (transl_code f c) rs m (transl_code f c') rs' m' -> + transl_code_at_pc (rs' PC) fb f c'. +Proof. + intros. inversion H. subst. + generalize (functions_transl_no_overflow _ _ H2). intro. + generalize (functions_transl _ _ H2). intro. + generalize (exec_straight_steps_2 _ _ _ _ _ _ _ + H0 H4 _ _ (sym_equal H1) H5 H3). + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + +(** Correctness of the return addresses predicted by + [ARMgen.return_address_offset]. *) + +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 b ofs fb f c ofs', + transl_code_at_pc (Vptr b ofs) fb f c -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H0. inv H. + generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H. + apply Int.repr_unsigned. +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: code) {struct c} : option code := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some c' else find_label lbl c' + 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 + code_size c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + intro EQ; injection EQ; intro; subst c'. + exists (pos + 1). split. auto. split. + replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. + generalize (code_size_pos c). omega. + intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. + constructor. auto. + omega. +Qed. + +(** The following lemmas show that the translation from Mach to ARM + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ ARM instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- ARM instr seq tail + translation +>> + The proof demands many boring lemmas showing that ARM constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Variable lbl: label. + +Remark loadimm_label: + forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. +Proof. + intros. unfold loadimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.not n)); reflexivity. +Qed. +Hint Rewrite loadimm_label: labels. + +Remark addimm_label: + forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold addimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.neg n)). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite addimm_label: labels. + +Remark andimm_label: + forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold andimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.not n)). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite andimm_label: labels. + +Remark makeimm_Prsb_label: + forall r1 r2 n k, find_label lbl (makeimm Prsb r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Remark makeimm_Porr_label: + forall r1 r2 n k, find_label lbl (makeimm Porr r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Remark makeimm_Peor_label: + forall r1 r2 n k, find_label lbl (makeimm Peor r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Hint Rewrite makeimm_Prsb_label makeimm_Porr_label makeimm_Peor_label: labels. + +Remark loadind_int_label: + forall base ofs dst k, find_label lbl (loadind_int base ofs dst k) = find_label lbl k. +Proof. + intros; unfold loadind_int. + destruct (is_immed_mem_word ofs); autorewrite with labels; auto. +Qed. + +Remark loadind_label: + forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. +Proof. + intros; unfold loadind. destruct ty. + apply loadind_int_label. + unfold loadind_float. + destruct (is_immed_mem_float ofs); autorewrite with labels; auto. +Qed. + +Remark storeind_int_label: + forall base ofs src k, find_label lbl (storeind_int src base ofs k) = find_label lbl k. +Proof. + intros; unfold storeind_int. + destruct (is_immed_mem_word ofs); autorewrite with labels; auto. +Qed. + +Remark storeind_label: + forall base ofs ty src k, find_label lbl (storeind src base ofs ty k) = find_label lbl k. +Proof. + intros; unfold storeind. destruct ty. + apply storeind_int_label. + unfold storeind_float. + destruct (is_immed_mem_float ofs); autorewrite with labels; auto. +Qed. +Hint Rewrite loadind_int_label loadind_label storeind_int_label storeind_label: labels. + +Remark transl_cond_label: + forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k. +Proof. + intros; unfold transl_cond. + destruct cond; (destruct args; + [try reflexivity | destruct args; + [try reflexivity | destruct args; try reflexivity]]). + destruct (is_immed_arith i); autorewrite with labels; auto. + destruct (is_immed_arith i); autorewrite with labels; auto. +Qed. +Hint Rewrite transl_cond_label: labels. + +Remark transl_op_label: + forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k. +Proof. + intros; unfold transl_op; + destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args); + try reflexivity; autorewrite with labels; try reflexivity. + case (mreg_type m); reflexivity. + case (ireg_eq (ireg_of r) (ireg_of m) || ireg_eq (ireg_of r) (ireg_of m0)); reflexivity. + transitivity (find_label lbl + (addimm IR14 (ireg_of m) (Int.sub (Int.shl Int.one i) Int.one) + (Pmovc CRge IR14 (SOreg (ireg_of m)) + :: Pmov (ireg_of r) (SOasrimm IR14 i) :: k))). + unfold find_label; auto. autorewrite with labels. reflexivity. +Qed. +Hint Rewrite transl_op_label: labels. + +Remark transl_load_store_label: + forall (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + (addr: addressing) (args: list mreg) (k: code), + (forall r n, is_label lbl (mk_instr_imm r n) = false) -> + (match mk_instr_gen with + | None => True + | Some f => forall r sa, is_label lbl (f r sa) = false + end) -> + find_label lbl (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) = find_label lbl k. +Proof. + intros; unfold transl_load_store. + destruct addr; destruct args; try (destruct args); try (destruct args); + try reflexivity. + destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto. + destruct mk_instr_gen. simpl. rewrite H0. auto. + simpl. rewrite H. auto. + destruct mk_instr_gen. simpl. rewrite H0. auto. + simpl. rewrite H. auto. + destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto. +Qed. +Hint Rewrite transl_load_store_label: labels. + +Lemma transl_instr_label: + forall f i k, + find_label lbl (transl_instr f i k) = + if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. generalize (Mach.is_label_correct lbl i). + case (Mach.is_label lbl i); intro. + subst i. simpl. rewrite peq_true. auto. + destruct i; simpl; autorewrite with labels; try reflexivity. + unfold transl_load_store_int, transl_load_store_float. + destruct m; rewrite transl_load_store_label; intros; auto. + unfold transl_load_store_int, transl_load_store_float. + destruct m; rewrite transl_load_store_label; intros; auto. + destruct s0; reflexivity. + destruct s0; autorewrite with labels; reflexivity. + rewrite peq_false. auto. congruence. +Qed. + +Lemma transl_code_label: + forall f c, + find_label lbl (transl_code f c) = + option_map (transl_code f) (Mach.find_label lbl c). +Proof. + induction c; simpl; intros. + auto. rewrite transl_instr_label. + case (Mach.is_label lbl a). reflexivity. + auto. +Qed. + +Lemma transl_find_label: + forall f, + find_label lbl (transl_function f) = + option_map (transl_code f) (Mach.find_label lbl f.(fn_code)). +Proof. + intros. unfold transl_function. simpl. autorewrite with labels. apply transl_code_label. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated ARM code. *) + +Lemma find_label_goto_label: + forall f lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + rs PC = Vptr b ofs -> + Mach.find_label lbl f.(fn_code) = Some c' -> + exists rs', + goto_label (transl_function f) lbl rs m = OK rs' m + /\ transl_code_at_pc (rs' PC) b f c' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. + generalize (transl_find_label lbl f). + rewrite H1; simpl. intro. + generalize (label_pos_code_tail lbl (transl_function f) 0 + (transl_code f c') H2). + intros [pos' [A [B C]]]. + exists (rs#PC <- (Vptr b (Int.repr pos'))). + split. unfold goto_label. rewrite A. rewrite H0. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B. + auto. omega. + generalize (functions_transl_no_overflow _ _ H). + omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** * Memory properties *) + +(** We show that signed 8- and 16-bit stores can be performed + like unsigned stores. *) + +Remark valid_access_equiv: + forall chunk1 chunk2 m b ofs, + size_chunk chunk1 = size_chunk chunk2 -> + valid_access m chunk1 b ofs -> + valid_access m chunk2 b ofs. +Proof. + intros. inv H0. rewrite H in H3. constructor; auto. +Qed. + +Remark in_bounds_equiv: + forall chunk1 chunk2 m b ofs (A: Set) (a1 a2: A), + size_chunk chunk1 = size_chunk chunk2 -> + (if in_bounds m chunk1 b ofs then a1 else a2) = + (if in_bounds m chunk2 b ofs then a1 else a2). +Proof. + intros. destruct (in_bounds m chunk1 b ofs). + rewrite in_bounds_true. auto. eapply valid_access_equiv; eauto. + destruct (in_bounds m chunk2 b ofs); auto. + elim n. eapply valid_access_equiv with (chunk1 := chunk2); eauto. +Qed. + +Lemma storev_8_signed_unsigned: + forall m a v, + Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + auto. auto. +Qed. + +Lemma storev_16_signed_unsigned: + forall m a v, + Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). + auto. auto. +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 ARM code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and ARM register values agree. +*) + +Inductive match_stack: list Machconcr.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + wt_function f -> + incl c f.(fn_code) -> + transl_code_at_pc ra fb f c -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Inductive match_states: Machconcr.state -> Asm.state -> Prop := + | match_states_intro: + forall s fb sp c ms m rs f + (STACKS: match_stack s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (WTF: wt_function f) + (INCL: incl c f.(fn_code)) + (AT: transl_code_at_pc (rs PC) fb f c) + (AG: agree ms sp rs), + match_states (Machconcr.State s fb sp c ms m) + (Asm.State rs m) + | match_states_call: + forall s fb ms m rs + (STACKS: match_stack s) + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Int.zero) + (ATLR: rs IR14 = parent_ra s), + match_states (Machconcr.Callstate s fb ms m) + (Asm.State rs m) + | match_states_return: + forall s ms m rs + (STACKS: match_stack s) + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machconcr.Returnstate s ms m) + (Asm.State rs m). + +Lemma exec_straight_steps: + forall s fb sp m1 f c1 rs1 c2 m2 ms2, + match_stack s -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + wt_function f -> + incl c2 f.(fn_code) -> + transl_code_at_pc (rs1 PC) fb f c1 -> + (exists rs2, + exec_straight tge (transl_function f) (transl_code f c1) rs1 m1 (transl_code f c2) rs2 m2 + /\ agree ms2 sp rs2) -> + exists st', + plus step tge (State rs1 m1) E0 st' /\ + match_states (Machconcr.State s fb sp c2 ms2 m2) st'. +Proof. + intros. destruct H4 as [rs2 [A B]]. + exists (State rs2 m2); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the ARM side. Actually, all Mach transitions + correspond to at least one ARM transition, except the + transition from [Machconcr.Returnstate] to [Machconcr.State]. + So, the following integer measure will suffice to rule out + the unwanted behaviour. *) + +Definition measure (s: Machconcr.state) : nat := + match s with + | Machconcr.State _ _ _ _ _ _ => 0%nat + | Machconcr.Callstate _ _ _ _ => 0%nat + | Machconcr.Returnstate _ _ _ => 1%nat + end. + +(** We show the simulation diagram by case analysis on the Mach transition + on the left. Since the proof is large, we break it into one lemma + per transition. *) + +Definition exec_instr_prop (s1: Machconcr.state) (t: trace) (s2: Machconcr.state) : Prop := + 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. + + +Lemma exec_Mlabel_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) + (m : mem), + exec_instr_prop (Machconcr.State s fb sp (Mlabel lbl :: c) ms m) E0 + (Machconcr.State s fb sp c ms m). +Proof. + intros; red; intros; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs); split. + simpl. apply exec_straight_one. reflexivity. reflexivity. + apply agree_nextinstr; auto. +Qed. + +Lemma exec_Mgetstack_prop: + forall (s : list stackframe) (fb : block) (sp : val) (ofs : int) + (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + load_stack m sp ty ofs = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set dst v ms) m). +Proof. + intros; red; intros; inv MS. + unfold load_stack in H. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + rewrite (sp_val _ _ _ AG) in H. + generalize (loadind_correct tge (transl_function f) IR13 ofs ty + dst (transl_code f c) rs m v H H1). + intros [rs2 [EX [RES OTH]]]. + left; eapply exec_straight_steps; eauto with coqlib. + simpl. exists rs2; split. auto. + apply agree_exten_2 with (rs#(preg_of dst) <- v). + auto with ppcgen. + intros. case (preg_eq r0 (preg_of dst)); intro. + subst r0. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso; auto. +Qed. + +Lemma exec_Msetstack_prop: + forall (s : list stackframe) (fb : block) (sp : val) (src : mreg) + (ofs : int) (ty : typ) (c : list Mach.instruction) + (ms : mreg -> val) (m m' : mem), + store_stack m sp ty ofs (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Msetstack src ofs ty :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). +Proof. + intros; red; intros; inv MS. + unfold store_stack in H. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + rewrite (sp_val _ _ _ AG) in H. + rewrite (preg_val ms sp rs) in H; auto. + assert (NOTE: IR13 <> IR14) by congruence. + generalize (storeind_correct tge (transl_function f) IR13 ofs ty + src (transl_code f c) rs m m' H H1 NOTE). + intros [rs2 [EX OTH]]. + left; eapply exec_straight_steps; eauto with coqlib. + exists rs2; split; auto. + apply agree_exten_2 with rs; auto. +Qed. + +Lemma exec_Mgetparam_prop: + forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tint f.(fn_link_ofs) = Some parent -> + load_stack m parent ty ofs = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set dst v ms) m). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_link_ofs) IR14 + rs m parent (loadind IR14 ofs ty dst (transl_code f c))). + rewrite <- (sp_val ms sp rs); auto. + intros [rs1 [EX1 [RES1 OTH1]]]. + exploit (loadind_correct tge (transl_function f) IR14 ofs ty dst + (transl_code f c) rs1 m v). + rewrite RES1. auto. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. auto. + intros [rs2 [EX2 [RES2 OTH2]]]. + left. eapply exec_straight_steps; eauto with coqlib. + exists rs2; split; simpl. + eapply exec_straight_trans; eauto. + apply agree_exten_2 with (rs1#(preg_of dst) <- v). + apply agree_set_mreg. + apply agree_exten_2 with rs; auto. + intros. case (preg_eq r (preg_of dst)); intro. + subst r. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso; auto. +Qed. + +Lemma exec_Mop_prop: + forall (s : list stackframe) (fb : block) (sp : val) (op : operation) + (args : list mreg) (res : mreg) (c : list Mach.instruction) + (ms : mreg -> val) (m : mem) (v : val), + eval_operation ge sp op ms ## args m = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set res v ms) m). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. + left; eapply exec_straight_steps; eauto with coqlib. + simpl. eapply transl_op_correct; auto. + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. +Qed. + +Lemma exec_Mload_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m : mem) (a v : val), + eval_addressing ge sp addr ms ## args = Some a -> + loadv chunk m a = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m) + E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI; inv WTI. + assert (eval_addressing tge sp addr ms##args = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; eapply exec_straight_steps; eauto with coqlib. + destruct chunk; simpl; simpl in H6; + (eapply transl_load_int_correct || eapply transl_load_float_correct); + eauto; intros; reflexivity. +Qed. + +Lemma exec_Mstore_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m m' : mem) (a : val), + eval_addressing ge sp addr ms ## args = Some a -> + storev chunk m a (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI; inv WTI. + assert (eval_addressing tge sp addr ms##args = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; eapply exec_straight_steps; eauto with coqlib. + destruct chunk; simpl; simpl in H6; + try (rewrite storev_8_signed_unsigned in H0); + try (rewrite storev_16_signed_unsigned in H0); + (eapply transl_store_int_correct || eapply transl_store_float_correct); + eauto; intros; reflexivity. +Qed. + +Lemma exec_Mcall_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (sig : signature) (ros : mreg + ident) (c : Mach.code) + (ms : Mach.regset) (m : mem) (f : function) (f' : block) + (ra : int), + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + return_address_offset f c ra -> + exec_instr_prop (Machconcr.State s fb sp (Mcall sig ros :: c) ms m) E0 + (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + inv AT. + assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). + eapply functions_transl_no_overflow; eauto. + assert (CT: code_tail (Int.unsigned (Int.add ofs Int.one)) (transl_function f) (transl_code f c)). + destruct ros; simpl in H5; eapply code_tail_next_int; eauto. + set (rs2 := rs #IR14 <- (Val.add rs#PC Vone) #PC <- (Vptr f' Int.zero)). + exploit return_address_offset_correct; eauto. constructor; eauto. + intro RA_EQ. + assert (ATLR: rs2 IR14 = Vptr fb ra). + rewrite RA_EQ. + change (rs2 IR14) with (Val.add (rs PC) Vone). + rewrite <- H2. reflexivity. + assert (AG3: agree ms sp rs2). + unfold rs2; auto 8 with ppcgen. + left; exists (State rs2 m); split. + apply plus_one. + destruct ros; simpl in H5. + econstructor. eauto. apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + simpl in H. destruct (ms m0); try congruence. + generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H7. + auto. + econstructor. eauto. apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. unfold symbol_offset. rewrite symbols_preserved. + simpl in H. rewrite H. auto. + econstructor; eauto. + econstructor; eauto with coqlib. + rewrite RA_EQ. econstructor; eauto. +Qed. + +Lemma exec_Mtailcall_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (sig : signature) (ros : mreg + ident) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (f: function) (f' : block), + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + exec_instr_prop + (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 + (Callstate s f' ms (free m stk)). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + set (call_instr := + match ros with inl r => Pbreg (ireg_of r) | inr symb => Pbsymb symb end). + assert (TR: transl_code f (Mtailcall sig ros :: c) = + loadind_int IR13 (fn_retaddr_ofs f) IR14 + (Pfreeframe (fn_link_ofs f) :: call_instr :: transl_code f c)). + unfold call_instr; destruct ros; auto. + destruct (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 + rs m (parent_ra s) + (Pfreeframe f.(fn_link_ofs) :: call_instr :: transl_code f c)) + as [rs1 [EXEC1 [RES1 OTH1]]]. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). + assert (EXEC2: exec_straight tge (transl_function f) + (transl_code f (Mtailcall sig ros :: c)) rs m + (call_instr :: transl_code f c) rs2 (free m stk)). + rewrite TR. eapply exec_straight_trans. eexact EXEC1. + apply exec_straight_one. simpl. + rewrite OTH1; auto with ppcgen. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + unfold load_stack in H1. simpl in H1. simpl. rewrite H1. auto. auto. + set (rs3 := rs2#PC <- (Vptr f' Int.zero)). + left. exists (State rs3 (free m stk)); split. + (* Execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + inv AT. exploit exec_straight_steps_2; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs2 [RS2PC CT]]. + econstructor. eauto. eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + unfold call_instr; destruct ros; simpl in H; simpl. + replace (rs2 (ireg_of m0)) with (Vptr f' Int.zero). auto. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso. rewrite OTH1; auto with ppcgen. + rewrite <- (ireg_val ms (Vptr stk soff) rs); auto. + destruct (ms m0); try discriminate. + generalize H. predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H9. + auto. + decEq. auto with ppcgen. decEq. auto with ppcgen. decEq. auto with ppcgen. + replace (symbol_offset tge i Int.zero) with (Vptr f' Int.zero). auto. + unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto. + traceEq. + (* Match states *) + constructor; auto. + assert (AG1: agree ms (Vptr stk soff) rs1). + eapply agree_exten_2; eauto. + assert (AG2: agree ms (parent_sp s) rs2). + inv AG1. constructor. auto. intros. unfold rs2. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso. auto. auto with ppcgen. + unfold rs3. apply agree_exten_2 with rs2; auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma exec_Malloc_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (sz : int) + (m' : mem) (blk : block), + ms Conventions.loc_alloc_argument = Vint sz -> + alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr_prop (Machconcr.State s fb sp (Malloc :: c) ms m) E0 + (Machconcr.State s fb sp c + (Regmap.set (Conventions.loc_alloc_result) (Vptr blk Int.zero) ms) m'). +Proof. + intros; red; intros; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + simpl. eapply transl_alloc_correct; eauto. +Qed. + +Lemma exec_Mgoto_prop: + forall (s : list stackframe) (fb : block) (f : function) (sp : val) + (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) + (m : mem) (c' : Mach.code), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl (fn_code f) = Some c' -> + exec_instr_prop (Machconcr.State s fb sp (Mgoto lbl :: c) ms m) E0 + (Machconcr.State s fb sp c' ms m). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + inv AT. simpl in H3. + generalize (find_label_goto_label f lbl rs m _ _ _ FIND (sym_equal H1) H0). + intros [rs2 [GOTO [AT2 INV]]]. + left; exists (State rs2 m); split. + apply plus_one. econstructor; eauto. + apply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; auto. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs; auto. +Qed. + +Lemma exec_Mcond_true_prop: + forall (s : list stackframe) (fb : block) (f : function) (sp : val) + (cond : condition) (args : list mreg) (lbl : Mach.label) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem) + (c' : Mach.code), + eval_condition cond ms ## args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl (fn_code f) = Some c' -> + exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 + (Machconcr.State s fb sp c' ms m). +Proof. + intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + pose (k1 := Pbc (crbit_for_cond cond) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m true H3 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + inv AT. simpl in H5. + generalize (functions_transl _ _ H4); intro FN. + generalize (functions_transl_no_overflow _ _ H4); intro NOOV. + exploit exec_straight_steps_2; eauto. + intros [ofs' [PC2 CT2]]. + generalize (find_label_goto_label f lbl rs2 m _ _ _ FIND PC2 H1). + intros [rs3 [GOTO [AT3 INV3]]]. + left; exists (State rs3 m); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2. eauto. + simpl. rewrite RES. simpl. auto. + traceEq. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs2; auto. +Qed. + +Lemma exec_Mcond_false_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (cond : condition) (args : list mreg) (lbl : Mach.label) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem), + eval_condition cond ms ## args m = Some false -> + exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 + (Machconcr.State s fb sp c ms m). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + pose (k1 := Pbc (crbit_for_cond cond) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m false H1 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs2); split. + simpl. eapply exec_straight_trans. eexact EX. + unfold k1; apply exec_straight_one. + simpl. rewrite RES. reflexivity. + reflexivity. + auto with ppcgen. +Qed. + +Lemma exec_Mreturn_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: function), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 + (Returnstate s ms (free m stk)). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 + rs m (parent_ra s) + (Pfreeframe f.(fn_link_ofs) :: Pbreg IR14 :: transl_code f c)). + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + intros [rs1 [EXEC1 [RES1 OTH1]]]. + set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). + assert (EXEC2: exec_straight tge (transl_function f) + (loadind_int IR13 (fn_retaddr_ofs f) IR14 + (Pfreeframe (fn_link_ofs f) :: Pbreg IR14 :: transl_code f c)) + rs m (Pbreg IR14 :: transl_code f c) rs2 (free m stk)). + eapply exec_straight_trans. eexact EXEC1. + apply exec_straight_one. simpl. rewrite OTH1; try congruence. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + unfold load_stack in H0. simpl in H0; simpl; rewrite H0. reflexivity. + reflexivity. + set (rs3 := rs2#PC <- (parent_ra s)). + left; exists (State rs3 (free m stk)); split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + inv AT. exploit exec_straight_steps_2; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs2 [RS2PC CT]]. + econstructor. eauto. eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl. unfold rs3. decEq. decEq. unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + traceEq. + (* match states *) + constructor. auto. + assert (AG1: agree ms (Vptr stk soff) rs1). + apply agree_exten_2 with rs; auto. + assert (AG2: agree ms (parent_sp s) rs2). + constructor. reflexivity. intros; unfold rs2. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso; auto with ppcgen. + inv AG1; auto. + unfold rs3. auto with ppcgen. + reflexivity. +Qed. + +Hypothesis wt_prog: wt_program prog. + +Lemma exec_function_internal_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> + let sp := Vptr stk (Int.repr (- fn_framesize f)) in + store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + exec_instr_prop (Machconcr.Callstate s fb ms m) E0 + (Machconcr.State s fb sp (fn_code f) ms m3). +Proof. + intros; red; intros; inv MS. + assert (WTF: wt_function f). + generalize (Genv.find_funct_ptr_prop wt_fundef wt_prog H); intro TY. + inversion TY; auto. + exploit functions_transl; eauto. intro TFIND. + generalize (functions_transl_no_overflow _ _ H); intro NOOV. + set (rs2 := nextinstr (rs#IR13 <- sp)). + set (rs3 := nextinstr rs2). + (* Execution of function prologue *) + assert (EXEC_PROLOGUE: + exec_straight tge (transl_function f) + (transl_function f) rs m + (transl_code f f.(fn_code)) rs3 m3). + unfold transl_function at 2. + apply exec_straight_two with rs2 m2. + unfold exec_instr. rewrite H0. fold sp. + rewrite <- (sp_val ms (parent_sp s) rs); auto. + unfold store_stack in H1. change Mint32 with (chunk_of_type Tint). rewrite H1. + auto. + unfold exec_instr. unfold eval_shift_addr. unfold exec_store. + change (rs2 IR13) with sp. change (rs2 IR14) with (rs IR14). rewrite ATLR. + unfold store_stack in H2. change Mint32 with (chunk_of_type Tint). rewrite H2. + auto. auto. auto. + (* Agreement at end of prologue *) + assert (AT3: transl_code_at_pc rs3#PC fb f f.(fn_code)). + change (rs3 PC) with (Val.add (Val.add (rs PC) Vone) Vone). + rewrite ATPC. simpl. constructor. auto. + eapply code_tail_next_int; auto. + eapply code_tail_next_int; auto. + change (Int.unsigned Int.zero) with 0. + unfold transl_function. constructor. + assert (AG2: agree ms sp rs2). + split. reflexivity. + intros. unfold rs2. rewrite nextinstr_inv. + repeat (rewrite Pregmap.gso). elim AG; auto. + auto with ppcgen. auto with ppcgen. + assert (AG3: agree ms sp rs3). + unfold rs3; auto with ppcgen. + left; exists (State rs3 m3); split. + (* execution *) + eapply exec_straight_steps_1; eauto. + change (Int.unsigned Int.zero) with 0. constructor. + (* match states *) + econstructor; eauto with coqlib. +Qed. + +Lemma exec_function_external_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (t0 : trace) (ms' : RegEq.t -> val) + (ef : external_function) (args : list val) (res : val), + Genv.find_funct_ptr ge fb = Some (External ef) -> + event_match ef args t0 res -> + Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args -> + ms' = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms -> + exec_instr_prop (Machconcr.Callstate s fb ms m) + t0 (Machconcr.Returnstate s ms' m). +Proof. + intros; red; intros; inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs IR14)) + m); split. + apply plus_one. eapply exec_step_external; eauto. + eapply extcall_arguments_match; eauto. + econstructor; eauto. + unfold loc_external_result. auto with ppcgen. +Qed. + +Lemma exec_return_prop: + forall (s : list stackframe) (fb : block) (sp ra : val) + (c : Mach.code) (ms : Mach.regset) (m : mem), + exec_instr_prop (Machconcr.Returnstate (Stackframe fb sp ra c :: s) ms m) E0 + (Machconcr.State s fb sp c ms m). +Proof. + intros; red; intros; inv MS. inv STACKS. simpl in *. + right. split. omega. split. auto. + econstructor; eauto. rewrite ATPC; auto. +Qed. + +Theorem transf_instr_correct: + forall s1 t s2, Machconcr.step ge s1 t s2 -> + exec_instr_prop s1 t s2. +Proof + (Machconcr.step_ind ge exec_instr_prop + exec_Mlabel_prop + exec_Mgetstack_prop + exec_Msetstack_prop + exec_Mgetparam_prop + exec_Mop_prop + exec_Mload_prop + exec_Mstore_prop + exec_Mcall_prop + exec_Mtailcall_prop + exec_Malloc_prop + exec_Mgoto_prop + exec_Mcond_true_prop + exec_Mcond_false_prop + exec_Mreturn_prop + exec_function_internal_prop + exec_function_external_prop + exec_return_prop). + +Lemma transf_initial_states: + forall st1, Machconcr.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. + replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero) + with (Vptr fb Int.zero). + rewrite (Genv.init_mem_transf_partial _ _ TRANSF). + econstructor; eauto. constructor. + split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen. + unfold symbol_offset. + rewrite (transform_partial_program_main _ _ TRANSF). + rewrite symbols_preserved. unfold ge; rewrite H0. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Machconcr.final_state st1 r -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. auto. + compute in H1. + rewrite (ireg_val _ _ _ R0 AG) in H1. auto. auto. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Machconcr.exec_program prog beh -> Asm.exec_program tprog beh. +Proof. + unfold Machconcr.exec_program, Asm.exec_program; intros. + eapply simulation_star_preservation with (measure := measure); eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_instr_correct. +Qed. + +End PRESERVATION. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v new file mode 100644 index 0000000..32fedf3 --- /dev/null +++ b/arm/Asmgenproof1.v @@ -0,0 +1,1507 @@ +(* *********************************************************************) +(* *) +(* 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 ARM code generation: auxiliary results. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import Machconcr. +Require Import Machtyping. +Require Import Asm. +Require Import Asmgen. +Require Conventions. + +(** * Correspondence between Mach registers and PPC registers *) + +Hint Extern 2 (_ <> _) => discriminate: ppcgen. + +(** Mapping from Mach registers to PPC registers. *) + +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. + +(** Characterization of PPC registers that correspond to Mach registers. *) + +Definition is_data_reg (r: preg) : Prop := + match r with + | IR IR14 => False + | CR _ => False + | PC => False + | _ => True + end. + +Lemma ireg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma freg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma preg_of_is_data_reg: + forall (r: mreg), is_data_reg (preg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma ireg_of_not_IR13: + forall r, ireg_of r <> IR13. +Proof. + intro. case r; discriminate. +Qed. +Lemma ireg_of_not_IR14: + forall r, ireg_of r <> IR14. +Proof. + intro. case r; discriminate. +Qed. + +Hint Resolve ireg_of_not_IR13 ireg_of_not_IR14: ppcgen. + +Lemma preg_of_not: + forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2. +Proof. + intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg. +Qed. +Hint Resolve preg_of_not: ppcgen. + +Lemma preg_of_not_IR13: + forall r, preg_of r <> IR13. +Proof. + intro. case r; discriminate. +Qed. +Hint Resolve preg_of_not_IR13: ppcgen. + +(** Agreement between Mach register sets and PPC register sets. *) + +Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) := + rs#IR13 = sp /\ forall r: mreg, ms r = rs#(preg_of r). + +Lemma preg_val: + forall ms sp rs r, + agree ms sp rs -> ms r = rs#(preg_of r). +Proof. + intros. elim H. auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tint -> + ms r = rs#(ireg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma freg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tfloat -> + ms r = rs#(freg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, + agree ms sp rs -> + sp = rs#IR13. +Proof. + intros. elim H; auto. +Qed. + +Lemma agree_exten_1: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, is_data_reg r -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + unfold agree; intros. elim H; intros. + split. rewrite H0. auto. exact I. + intros. rewrite H0. auto. apply preg_of_is_data_reg. +Qed. + +Lemma agree_exten_2: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. eapply agree_exten_1; eauto. + intros. apply H0; red; intro; subst r; elim H1. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v, + agree ms sp rs -> + agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v). +Proof. + unfold agree; intros. elim H; intros; clear H. + split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_IR13. + intros. unfold Regmap.set. case (RegEq.eq r0 r); intro. + subst r0. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso. auto. red; intro. + elim n. apply preg_of_injective; auto. +Qed. +Hint Resolve agree_set_mreg: ppcgen. + +Lemma agree_set_mireg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tint -> + agree ms sp (rs#(ireg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mireg: ppcgen. + +Lemma agree_set_mfreg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tfloat -> + agree ms sp (rs#(freg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mfreg: ppcgen. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + ~(is_data_reg r) -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten_1 with rs. + auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction. +Qed. +Hint Resolve agree_set_other: ppcgen. + +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. +Hint Resolve agree_nextinstr: ppcgen. + +Lemma agree_set_mireg_twice: + forall ms sp rs r v v', + agree ms sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v). +Proof. + intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros. + split. repeat (rewrite Pregmap.gso; auto with ppcgen). + intros. case (mreg_eq r r0); intro. + subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto. + assert (preg_of r <> preg_of r0). + red; intro. elim n. apply preg_of_injective. auto. + rewrite Regmap.gso; auto. + repeat (rewrite Pregmap.gso; auto). + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_mireg_twice: ppcgen. + +Lemma agree_set_twice_mireg: + forall ms sp rs r v v', + agree (Regmap.set r v' ms) sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v). +Proof. + intros. elim H; intros. + split. rewrite Pregmap.gso. auto. + generalize (ireg_of_not_IR13 r); congruence. + intros. generalize (H2 r0). + case (mreg_eq r0 r); intro. + subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0. + rewrite Pregmap.gss. auto. + repeat rewrite Regmap.gso; auto. + rewrite Pregmap.gso. auto. + replace (IR (ireg_of r)) with (preg_of r). + red; intros. elim n. apply preg_of_injective; auto. + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_twice_mireg: ppcgen. + +Lemma agree_set_commut: + forall ms sp rs r1 r2 v1 v2, + r1 <> r2 -> + agree ms sp ((rs#r2 <- v2)#r1 <- v1) -> + agree ms sp ((rs#r1 <- v1)#r2 <- v2). +Proof. + intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto. + intros. + case (preg_eq r r1); intro. + subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + case (preg_eq r r2); intro. + subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + repeat (rewrite Pregmap.gso; auto). +Qed. +Hint Resolve agree_set_commut: ppcgen. + +Lemma agree_nextinstr_commut: + forall ms sp rs r v, + agree ms sp (rs#r <- v) -> + r <> PC -> + agree ms sp ((nextinstr rs)#r <- v). +Proof. + intros. unfold nextinstr. apply agree_set_commut. auto. + apply agree_set_other. auto. auto. +Qed. +Hint Resolve agree_nextinstr_commut: ppcgen. + +Lemma agree_set_mireg_exten: + forall ms sp rs r v (rs': regset), + agree ms sp rs -> + mreg_type r = Tint -> + rs'#(ireg_of r) = v -> + (forall r', r' <> PC -> r' <> ireg_of r -> r' <> IR14 -> rs'#r' = rs#r') -> + agree (Regmap.set r v ms) sp rs'. +Proof. + intros. apply agree_exten_2 with (rs#(ireg_of r) <- v). + auto with ppcgen. + intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro. + subst r0. auto. apply H2; auto. +Qed. + +(** Useful properties of the PC and GPR0 registers. *) + +Lemma nextinstr_inv: + forall r rs, r <> PC -> (nextinstr rs)#r = rs#r. +Proof. + intros. unfold nextinstr. apply Pregmap.gso. auto. +Qed. +Hint Resolve nextinstr_inv: ppcgen. + +Lemma nextinstr_set_preg: + forall rs m v, + (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. +Proof. + intros. unfold nextinstr. rewrite Pregmap.gss. + rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen. +Qed. +Hint Resolve nextinstr_set_preg: ppcgen. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m l v, + agree ms sp rs -> + Machconcr.extcall_arg ms m sp l v -> + Asm.extcall_arg rs m l v. +Proof. + intros. inv H0. + rewrite (preg_val _ _ _ r H). constructor. + rewrite (sp_val _ _ _ H) in H1. + destruct ty; unfold load_stack in H1. + econstructor. reflexivity. assumption. + econstructor. reflexivity. assumption. +Qed. + +Lemma extcall_args_match: + forall ms sp rs m, agree ms sp rs -> + forall ll vl, + Machconcr.extcall_args ms m sp ll vl -> + Asm.extcall_args rs m ll vl. +Proof. + induction 2; constructor; auto. eapply extcall_arg_match; eauto. +Qed. + +Lemma extcall_arguments_match: + forall ms m sp rs sg args, + agree ms sp rs -> + Machconcr.extcall_arguments ms m sp sg args -> + Asm.extcall_arguments rs m sg args. +Proof. + unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +(** * Execution of straight-line code *) + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: code. + +(** Straight-line code is composed of PPC 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: code -> regset -> mem -> + code -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + rs2#PC = Val.add rs1#PC Vone -> + exec_straight (i1 :: c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_instr ge fn i rs1 m1 = OK rs2 m2 -> + rs2#PC = Val.add rs1#PC Vone -> + exec_straight c rs2 m2 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, + 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_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + 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 i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + rs4#PC = Val.add rs3#PC Vone -> + 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. + +Lemma exec_straight_four: + forall i1 i2 i3 i4 c rs1 m1 rs2 m2 rs3 m3 rs4 m4 rs5 m5, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> + exec_instr ge fn i4 rs4 m4 = OK rs5 m5 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + rs4#PC = Val.add rs3#PC Vone -> + rs5#PC = Val.add rs4#PC Vone -> + exec_straight (i1 :: i2 :: i3 :: i4 :: c) rs1 m1 c rs5 m5. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_three; eauto. +Qed. + +(** * Correctness of ARM constructor functions *) + +(** Properties of comparisons. *) +(* +Lemma compare_float_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_float rs v1 v2) in + rs1#CR0_0 = Val.cmpf Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_float. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_sint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_sint rs v1 v2) in + rs1#CR0_0 = Val.cmp Clt v1 v2 + /\ rs1#CR0_1 = Val.cmp Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmp Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_sint. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_uint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_uint rs v1 v2) in + rs1#CR0_0 = Val.cmpu Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_uint. repeat (rewrite Pregmap.gso; auto). +Qed. +*) + +(** Loading a constant. *) + +Lemma loadimm_correct: + forall r n k rs m, + exists rs', + exec_straight (loadimm r n k) rs m k rs' m + /\ rs'#r = Vint n + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold loadimm. + case (is_immed_arith n). + (* single move *) + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + case (is_immed_arith (Int.not n)). + (* single move-complement *) + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. + simpl. change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). + rewrite Int.not_involutive. auto. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* mov - or - or - or *) + set (n1 := Int.and n (Int.repr 255)). + set (n2 := Int.and n (Int.repr 65280)). + set (n3 := Int.and n (Int.repr 16711680)). + set (n4 := Int.and n (Int.repr 4278190080)). + set (rs1 := nextinstr (rs#r <- (Vint n1))). + set (rs2 := nextinstr (rs1#r <- (Val.or rs1#r (Vint n2)))). + set (rs3 := nextinstr (rs2#r <- (Val.or rs2#r (Vint n3)))). + set (rs4 := nextinstr (rs3#r <- (Val.or rs3#r (Vint n4)))). + exists rs4. + split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. + split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite Val.or_assoc. simpl. decEq. + unfold n4, n3, n2, n1. repeat rewrite <- Int.and_or_distrib. + change (Int.and n Int.mone = n). apply Int.and_mone. + intros. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Add integer immediate. *) + +Lemma addimm_correct: + forall r1 r2 n k rs m, + exists rs', + exec_straight (addimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.add rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold addimm. + (* addi *) + case (is_immed_arith n). + exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* subi *) + case (is_immed_arith (Int.neg n)). + exists (nextinstr (rs#r1 <- (Val.sub rs#r2 (Vint (Int.neg n))))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + apply Val.sub_opp_add. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general *) + set (n1 := Int.and n (Int.repr 255)). + set (n2 := Int.and n (Int.repr 65280)). + set (n3 := Int.and n (Int.repr 16711680)). + set (n4 := Int.and n (Int.repr 4278190080)). + set (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n1)))). + set (rs2 := nextinstr (rs1#r1 <- (Val.add rs1#r1 (Vint n2)))). + set (rs3 := nextinstr (rs2#r1 <- (Val.add rs2#r1 (Vint n3)))). + set (rs4 := nextinstr (rs3#r1 <- (Val.add rs3#r1 (Vint n4)))). + exists rs4. + split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. + simpl. + split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite Val.add_assoc. simpl. decEq. decEq. + unfold n4, n3, n2, n1. repeat rewrite Int.add_and. + change (Int.and n Int.mone = n). apply Int.and_mone. + vm_compute; auto. + vm_compute; auto. + vm_compute; auto. + intros. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(* And integer immediate *) + +Lemma andimm_correct: + forall r1 r2 n k rs m, + r2 <> IR14 -> + exists rs', + exec_straight (andimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.and rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> IR14 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold andimm. + (* andi *) + case (is_immed_arith n). + exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* bici *) + case (is_immed_arith (Int.not n)). + exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. simpl. + change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). + rewrite Int.not_involutive. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general *) + exploit loadimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#r1 <- (Val.and rs#r2 (Vint n)))). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. rewrite B. rewrite C; auto with ppcgen. congruence. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Other integer immediate *) + +Lemma makeimm_correct: + forall (instr: ireg -> ireg -> shift_op -> instruction) + (sem: val -> val -> val) + r1 (r2: ireg) n k (rs : regset) m, + (forall c r1 r2 so rs m, + exec_instr ge c (instr r1 r2 so) rs m + = OK (nextinstr rs#r1 <- (sem rs#r2 (eval_shift_op so rs))) m) -> + r2 <> IR14 -> + exists rs', + exec_straight (makeimm instr r1 r2 n k) rs m k rs' m + /\ rs'#r1 = sem rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> r' <> IR14 -> rs'#r' = rs#r'. +Proof. + intros. unfold makeimm. + case (is_immed_arith n). + (* one immed instr *) + exists (nextinstr (rs#r1 <- (sem rs#r2 (Vint n)))). + split. apply exec_straight_one. + change (Vint n) with (eval_shift_op (SOimm n) rs). auto. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general case *) + exploit loadimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#r1 <- (sem rs#r2 (Vint n)))). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + rewrite <- B. rewrite <- (C r2). + change (rs' IR14) with (eval_shift_op (SOreg IR14) rs'). auto. + congruence. auto with ppcgen. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto with ppcgen. +Qed. + +(** Indexed memory loads. *) + +Lemma loadind_int_correct: + forall (base: ireg) ofs dst (rs: regset) m v k, + Mem.loadv Mint32 m (Val.add rs#base (Vint ofs)) = Some v -> + exists rs', + exec_straight (loadind_int base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r. +Proof. + intros; unfold loadind_int. destruct (is_immed_mem_word ofs). + exists (nextinstr (rs#dst <- v)). + split. apply exec_straight_one. simpl. + unfold exec_load. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + exploit addimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#dst <- v)). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_load. rewrite B. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma loadind_float_correct: + forall (base: ireg) ofs dst (rs: regset) m v k, + Mem.loadv Mfloat64 m (Val.add rs#base (Vint ofs)) = Some v -> + exists rs', + exec_straight (loadind_float base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r. +Proof. + intros; unfold loadind_float. destruct (is_immed_mem_float ofs). + exists (nextinstr (rs#dst <- v)). + split. apply exec_straight_one. simpl. + unfold exec_load. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#dst <- v)). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_load. rewrite B. rewrite Val.add_assoc. simpl. + rewrite Int.add_zero. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k (rs: regset) m v, + Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + mreg_type dst = ty -> + exists rs', + exec_straight (loadind base ofs ty dst k) rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> IR14 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros. unfold loadind. + assert (preg_of dst <> PC). + unfold preg_of. case (mreg_type dst); discriminate. + unfold preg_of. rewrite H0. destruct ty. + apply loadind_int_correct; auto. + apply loadind_float_correct; auto. +Qed. + +(** Indexed memory stores. *) + +Lemma storeind_int_correct: + forall (base: ireg) ofs (src: ireg) (rs: regset) m m' k, + Mem.storev Mint32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' -> + src <> IR14 -> + exists rs', + exec_straight (storeind_int src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros; unfold storeind_int. destruct (is_immed_mem_word ofs). + exists (nextinstr rs). + split. apply exec_straight_one. simpl. + unfold exec_store. rewrite H. auto. auto. + intros. rewrite nextinstr_inv; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr rs'). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_store. rewrite B. rewrite C. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + congruence. auto with ppcgen. auto. + intros. rewrite nextinstr_inv; auto. +Qed. + +Lemma storeind_float_correct: + forall (base: ireg) ofs (src: freg) (rs: regset) m m' k, + Mem.storev Mfloat64 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' -> + base <> IR14 -> + exists rs', + exec_straight (storeind_float src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros; unfold storeind_float. destruct (is_immed_mem_float ofs). + exists (nextinstr rs). + split. apply exec_straight_one. simpl. + unfold exec_store. rewrite H. auto. auto. + intros. rewrite nextinstr_inv; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr rs'). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_store. rewrite B. rewrite C. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + congruence. congruence. auto with ppcgen. auto. + intros. rewrite nextinstr_inv; auto. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k (rs: regset) m m', + Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + mreg_type src = ty -> + base <> IR14 -> + exists rs', + exec_straight (storeind src base ofs ty k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros. unfold storeind. unfold preg_of in H. rewrite H0 in H. destruct ty. + apply storeind_int_correct. auto. auto. auto with ppcgen. + apply storeind_float_correct. auto. auto. +Qed. + +(** Translation of shift immediates *) + +Lemma transl_shift_correct: + forall s (r: ireg) (rs: regset), + eval_shift_op (transl_shift s r) rs = eval_shift_total s (rs#r). +Proof. + intros. destruct s; simpl; + unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; + rewrite (s_amount_ltu s); auto. +Qed. + +Lemma transl_shift_addr_correct: + forall s (r: ireg) (rs: regset), + eval_shift_addr (transl_shift_addr s r) rs = eval_shift_total s (rs#r). +Proof. + intros. destruct s; simpl; + unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; + rewrite (s_amount_ltu s); auto. +Qed. + +(** Translation of conditions *) + +Ltac TypeInv := + match goal with + | H: (List.map ?f ?x = nil) |- _ => + destruct x; [clear H | simpl in H; discriminate] + | H: (List.map ?f ?x = ?hd :: ?tl) |- _ => + destruct x; simpl in H; + [ discriminate | + injection H; clear H; let T := fresh "T" in ( + intros H T; TypeInv) ] + | _ => idtac + end. + +(** Translation of conditions. *) + +Lemma compare_int_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_int rs v1 v2) in + rs1#CReq = (Val.cmp Ceq v1 v2) + /\ rs1#CRne = (Val.cmp Cne v1 v2) + /\ rs1#CRhs = (Val.cmpu Cge v1 v2) + /\ rs1#CRlo = (Val.cmpu Clt v1 v2) + /\ rs1#CRhi = (Val.cmpu Cgt v1 v2) + /\ rs1#CRls = (Val.cmpu Cle v1 v2) + /\ rs1#CRge = (Val.cmp Cge v1 v2) + /\ rs1#CRlt = (Val.cmp Clt v1 v2) + /\ rs1#CRgt = (Val.cmp Cgt v1 v2) + /\ rs1#CRle = (Val.cmp Cle v1 v2) + /\ forall r', is_data_reg r' -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. intuition; try reflexivity. + rewrite nextinstr_inv; [unfold compare_int; repeat rewrite Pregmap.gso; auto | idtac]; + red; intro; subst r'; elim H. +Qed. + +Lemma compare_float_spec: + forall rs v1 v2, + let rs' := nextinstr (compare_float rs v1 v2) in + rs'#CReq = (Val.cmpf Ceq v1 v2) + /\ rs'#CRne = (Val.cmpf Cne v1 v2) + /\ rs'#CRmi = (Val.cmpf Clt v1 v2) + /\ rs'#CRpl = (Val.notbool (Val.cmpf Clt v1 v2)) + /\ rs'#CRhi = (Val.notbool (Val.cmpf Cle v1 v2)) + /\ rs'#CRls = (Val.cmpf Cle v1 v2) + /\ rs'#CRge = (Val.cmpf Cge v1 v2) + /\ rs'#CRlt = (Val.notbool (Val.cmpf Cge v1 v2)) + /\ rs'#CRgt = (Val.cmpf Cgt v1 v2) + /\ rs'#CRle = (Val.notbool (Val.cmpf Cgt v1 v2)) + /\ forall r', is_data_reg r' -> rs'#r' = rs#r'. +Proof. + intros. unfold rs'. intuition; try reflexivity. + rewrite nextinstr_inv; [unfold compare_float; repeat rewrite Pregmap.gso; auto | idtac]; + red; intro; subst r'; elim H. +Qed. + +Lemma transl_cond_correct: + forall cond args k ms sp rs m b, + map mreg_type args = type_of_condition cond -> + agree ms sp rs -> + eval_condition cond (map ms args) m = Some b -> + exists rs', + exec_straight (transl_cond cond args k) rs m k rs' m + /\ rs'#(CR (crbit_for_cond cond)) = Val.of_bool b + /\ agree ms sp rs'. +Proof. + intros. + rewrite <- (eval_condition_weaken _ _ _ H1). clear H1. + destruct cond; simpl in H; TypeInv; simpl. + (* Ccomp *) + generalize (compare_int_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompu *) + generalize (compare_int_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompshift *) + generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))). + split. apply exec_straight_one. simpl. + rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompushift *) + generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))). + split. apply exec_straight_one. simpl. + rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompimm *) + destruct (is_immed_arith i). + generalize (compare_int_spec rs ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + rewrite <- (ireg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. + assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto. + generalize (compare_int_spec rs' ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs' ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. + rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs'; auto. + (* Ccompuimm *) + destruct (is_immed_arith i). + generalize (compare_int_spec rs ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + rewrite <- (ireg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. + assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto. + generalize (compare_int_spec rs' ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs' ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. + rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs'; auto. + (* Ccompf *) + generalize (compare_float_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_float rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (freg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Cnotcompf *) + generalize (compare_float_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_float rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (freg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + rewrite Val.negate_cmpf_ne. auto. + rewrite Val.negate_cmpf_eq. auto. + apply agree_exten_1 with rs; auto. +Qed. + +(** Translation of arithmetic operations. *) + +Ltac TranslOpSimpl := + match goal with + | |- exists rs' : regset, + exec_straight ?c ?rs ?m ?k rs' ?m /\ + agree (Regmap.set ?res ?v ?ms) ?sp rs' => + (exists (nextinstr (rs#(ireg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (ireg_val ms sp rs); auto); + simpl; try rewrite transl_shift_correct; reflexivity + | reflexivity ] + | auto with ppcgen ]) + || + (exists (nextinstr (rs#(freg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity + | reflexivity ] + | auto with ppcgen ]) + end. + +Lemma transl_op_correct: + forall op args res k ms sp rs m v, + wt_instr (Mop op args res) -> + agree ms sp rs -> + eval_operation ge sp op (map ms args) m = Some v -> + exists rs', + exec_straight (transl_op op args res k) rs m k rs' m + /\ agree (Regmap.set res v ms) sp rs'. +Proof. + intros. rewrite <- (eval_operation_weaken _ _ _ _ _ H1). (*clear H1; clear v.*) + inversion H. + (* Omove *) + simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). + split. caseEq (mreg_type r1); intro. + apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity. + auto with ppcgen. + apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity. + auto with ppcgen. + auto with ppcgen. + (* Other instructions *) + clear H2 H3 H5. + destruct op; simpl in H6; injection H6; clear H6; intros; + TypeInv; simpl; try (TranslOpSimpl). + (* Omove again *) + congruence. + (* Ointconst *) + generalize (loadimm_correct (ireg_of res) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. +(* + (* Ofloatconst *) + exists (nextinstr (rs#(freg_of res) <- (Vfloat f))). + split. apply exec_straight_one. reflexivity. reflexivity. + auto with ppcgen. + (* Oaddrsymbol *) + change (find_symbol_offset ge i i0) with (symbol_offset ge i i0). + set (v := symbol_offset ge i i0). + pose (rs1 := nextinstr (rs#GPR2 <- (high_half v))). + exists (nextinstr (rs1#(ireg_of res) <- v)). + split. apply exec_straight_two with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_zero. + unfold const_high. rewrite Val.add_commut. + rewrite high_half_zero. reflexivity. + simpl. rewrite gpr_or_zero_not_zero. 2: congruence. + unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gss. + fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half. + reflexivity. reflexivity. reflexivity. + unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto. + apply agree_set_mreg. apply agree_nextinstr. + apply agree_set_other. auto. simpl. tauto. +*) + (* Oaddrstack *) + generalize (addimm_correct (ireg_of res) IR13 i k rs m). + intros [rs' [EX [RES OTH]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (sp_val ms sp rs). auto. auto. + (* Ocast8signed *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 24))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))) with (Val.sign_ext 8 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + vm_compute; auto. + (* Ocast8unsigned *) + exists (nextinstr (rs#(ireg_of res) <- (Val.and (ms m0) (Vint (Int.repr 255))))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. + replace (Val.zero_ext 8 (ms m0)) + with (Val.and (ms m0) (Vint (Int.repr 255))). + auto with ppcgen. + destruct (ms m0); simpl; auto. rewrite Int.zero_ext_and. reflexivity. + vm_compute; auto. + (* Ocast16signed *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.sign_ext 16 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + vm_compute; auto. + (* Ocast16unsigned *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.zero_ext 16 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.zero_ext_shru_shl. reflexivity. + vm_compute; auto. + (* Oaddimm *) + generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Orsbimm *) + exploit (makeimm_correct Prsb (fun v1 v2 => Val.sub v2 v1) (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Omul *) + destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)). + set (rs1 := nextinstr (rs#IR14 <- (Val.mul (ms m0) (ms m1)))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#IR14))). + exists rs2; split. + apply exec_straight_two with rs1 m; auto. + simpl. repeat rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + apply agree_nextinstr. apply agree_nextinstr_commut. + apply agree_set_mireg; auto. apply agree_set_mreg. apply agree_set_other. auto. + simpl; auto. auto with ppcgen. discriminate. + TranslOpSimpl. + (* Oandimm *) + generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m + (ireg_of_not_IR14 m0)). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Oorimm *) + exploit (makeimm_correct Porr Val.or (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Oxorimm *) + exploit (makeimm_correct Peor Val.xor (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Oshrximm *) + assert (exists n, ms m0 = Vint n /\ Int.ltu i (Int.repr 31) = true). + simpl in H1. destruct (ms m0); try discriminate. + exists i0; split; auto. destruct (Int.ltu i (Int.repr 31)); discriminate || auto. + destruct H3 as [n [ARG1 LTU]]. + assert (LTU': Int.ltu i (Int.repr 32) = true). + exploit Int.ltu_inv. eexact LTU. intro. + unfold Int.ltu. apply zlt_true. + assert (Int.unsigned (Int.repr 31) < Int.unsigned (Int.repr 32)). vm_compute; auto. + omega. + assert (RSm0: rs (ireg_of m0) = Vint n). + rewrite <- ARG1. symmetry. eapply ireg_val; eauto. + set (islt := Int.lt n Int.zero). + set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero))). + assert (OTH1: forall r', is_data_reg r' -> rs1#r' = rs#r'). + generalize (compare_int_spec rs (Vint n) (Vint Int.zero)). + fold rs1. intros [A B]. intuition. + exploit (addimm_correct IR14 (ireg_of m0) (Int.sub (Int.shl Int.one i) Int.one)). + intros [rs2 [EXEC2 [RES2 OTH2]]]. + set (rs3 := nextinstr (if islt then rs2 else rs2#IR14 <- (Vint n))). + set (rs4 := nextinstr (rs3#(ireg_of res) <- (Val.shr rs3#IR14 (Vint i)))). + exists rs4; split. + apply exec_straight_step with rs1 m. + simpl. rewrite RSm0. auto. auto. + eapply exec_straight_trans. eexact EXEC2. + apply exec_straight_two with rs3 m. + simpl. rewrite OTH2. change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)). + unfold Val.cmp. change (Int.cmp Cge n Int.zero) with (negb islt). + rewrite OTH2. rewrite OTH1. rewrite RSm0. + unfold rs3. case islt; reflexivity. + apply ireg_of_is_data_reg. decEq; auto with ppcgen. auto with ppcgen. congruence. congruence. + simpl. auto. + auto. unfold rs3. case islt; auto. auto. + (* agreement *) + assert (RES4: rs4#(ireg_of res) = Vint(Int.shrx n i)). + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gss. + rewrite Int.shrx_shr. fold islt. unfold rs3. + repeat rewrite nextinstr_inv; auto. + case islt. rewrite RES2. rewrite OTH1. rewrite RSm0. + simpl. rewrite LTU'. auto. + apply ireg_of_is_data_reg. + rewrite Pregmap.gss. simpl. rewrite LTU'. auto. congruence. + exact LTU. auto with ppcgen. + assert (OTH4: forall r, is_data_reg r -> r <> ireg_of res -> rs4#r = rs#r). + intros. + assert (r <> PC). red; intro; subst r; elim H3. + assert (r <> IR14). red; intro; subst r; elim H3. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. + transitivity (rs2 r). + case islt. auto. apply Pregmap.gso; auto. + rewrite OTH2; auto. + apply agree_exten_1 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))). + auto with ppcgen. + intros. unfold Pregmap.set. destruct (PregEq.eq r (ireg_of res)). + subst r. rewrite ARG1. simpl. rewrite LTU'. auto. + auto. + (* Ointoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ointuoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ofloatofint *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ofloatofintu *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ocmp *) + assert (exists b, eval_condition c ms##args m = Some b /\ v = Val.of_bool b). + simpl in H1. destruct (eval_condition c ms##args m). + destruct b; inv H1. exists true; auto. exists false; auto. + discriminate. + destruct H5 as [b [EVC EQ]]. + exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. + rewrite (eval_condition_weaken _ _ _ EVC). + set (rs1 := nextinstr (rs'#(ireg_of res) <- (Vint Int.zero))). + set (rs2 := nextinstr (if b then (rs1#(ireg_of res) <- Vtrue) else rs1)). + exists rs2; split. + eapply exec_straight_trans. eauto. + apply exec_straight_two with rs1 m; auto. + simpl. replace (rs1 (crbit_for_cond c)) with (Val.of_bool b). + unfold rs2. destruct b; auto. + unfold rs2. destruct b; auto. + apply agree_set_mireg_exten with rs'; auto. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + destruct b. apply Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. unfold rs2. rewrite nextinstr_inv; auto. + transitivity (rs1 r'). destruct b; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. +Qed. + +Remark val_add_add_zero: + forall v1 v2, Val.add v1 v2 = Val.add (Val.add v1 v2) (Vint Int.zero). +Proof. + intros. destruct v1; destruct v2; simpl; auto; rewrite Int.add_zero; auto. +Qed. + +Lemma transl_load_store_correct: + forall (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + addr args k ms sp rs m ms' m', + (forall (r1: ireg) (rs1: regset) n k, + eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (Vint n) -> + agree ms sp rs1 -> + exists rs', + exec_straight (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\ + agree ms' sp rs') -> + match mk_instr_gen with + | None => True + | Some mk => + (forall (r1: ireg) (sa: shift_addr) (rs1: regset) k, + eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (eval_shift_addr sa rs1) -> + agree ms sp rs1 -> + exists rs', + exec_straight (mk r1 sa :: k) rs1 m k rs' m' /\ + agree ms' sp rs') + end -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + exists rs', + exec_straight (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) rs m + k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. destruct addr; simpl in H2; TypeInv; simpl. + (* Aindexed *) + case (is_immed i). + (* Aindexed, small displacement *) + apply H; eauto. simpl. rewrite (ireg_val ms sp rs); auto. + (* Aindexed, large displacement *) + exploit (addimm_correct IR14 (ireg_of t)); eauto with ppcgen. + intros [rs' [A [B C]]]. + exploit (H IR14 rs' Int.zero); eauto. + simpl. rewrite (ireg_val ms sp rs); auto. rewrite B. + rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity. + apply agree_exten_2 with rs; auto. + intros [rs'' [D E]]. + exists rs''; split. + eapply exec_straight_trans. eexact A. eexact D. auto. + (* Aindexed2 *) + destruct mk_instr_gen as [mk | ]. + (* binary form available *) + apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto. + (* binary form not available *) + set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (ms t0)))). + exploit (H IR14 rs' Int.zero); eauto. + simpl. repeat rewrite (ireg_val ms sp rs); auto. + unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero. + unfold rs'; auto with ppcgen. + intros [rs'' [A B]]. + exists rs''; split. + eapply exec_straight_step with (rs2 := rs'); eauto. + simpl. repeat rewrite <- (ireg_val ms sp rs); auto. + auto. + (* Aindexed2shift *) + destruct mk_instr_gen as [mk | ]. + (* binary form available *) + apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto. + rewrite transl_shift_addr_correct. auto. + (* binary form not available *) + set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (eval_shift_total s (ms t0))))). + exploit (H IR14 rs' Int.zero); eauto. + simpl. repeat rewrite (ireg_val ms sp rs); auto. + unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero. + unfold rs'; auto with ppcgen. + intros [rs'' [A B]]. + exists rs''; split. + eapply exec_straight_step with (rs2 := rs'); eauto. + simpl. rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); auto. + auto. + (* Ainstack *) + destruct (is_immed i). + (* Ainstack, short displacement *) + apply H. simpl. rewrite (sp_val ms sp rs); auto. auto. + (* Ainstack, large displacement *) + exploit (addimm_correct IR14 IR13); eauto with ppcgen. + intros [rs' [A [B C]]]. + exploit (H IR14 rs' Int.zero); eauto. + simpl. rewrite (sp_val ms sp rs); auto. rewrite B. + rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity. + apply agree_exten_2 with rs; auto. + intros [rs'' [D E]]. + exists rs''; split. + eapply exec_straight_trans. eexact A. eexact D. auto. +Qed. + +Lemma transl_load_int_correct: + forall (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a v, + (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 sa) rs1 m = + exec_load chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tint -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m + k rs' m + /\ agree (Regmap.set rd v ms) sp rs'. +Proof. + intros. unfold transl_load_store_int. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. + intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_load_float_correct: + forall (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a v, + (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 n) rs1 m = + exec_load chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tfloat -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m + k rs' m + /\ agree (Regmap.set rd v ms) sp rs'. +Proof. + intros. unfold transl_load_store_float. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr (rs1#(freg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_store_int_correct: + forall (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a m', + (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 sa) rs1 m = + exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tint -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.storev chunk m a (ms rd) = Some m' -> + exists rs', + exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m + k rs' m' + /\ agree ms sp rs'. +Proof. + intros. unfold transl_load_store_int. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_store_float_correct: + forall (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a m', + (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 n) rs1 m = + exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tfloat -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.storev chunk m a (ms rd) = Some m' -> + exists rs', + exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m + k rs' m' + /\ agree ms sp rs'. +Proof. + intros. unfold transl_load_store_float. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (freg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +(** Translation of allocations *) + +Lemma transl_alloc_correct: + forall ms sp rs sz m m' blk k, + agree ms sp rs -> + ms Conventions.loc_alloc_argument = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in + exists rs', + exec_straight (Pallocblock :: k) rs m k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. + pose (rs' := nextinstr (rs#IR0 <- (Vptr blk Int.zero) #IR14 <- (Val.add rs#PC Vone))). + exists rs'; split. + apply exec_straight_one. unfold exec_instr. + generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). + unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. + rewrite H1. reflexivity. + reflexivity. + unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. + change (IR IR0) with (preg_of Conventions.loc_alloc_result). + apply agree_set_mreg. auto. + simpl. tauto. +Qed. + +End STRAIGHTLINE. + diff --git a/arm/Asmgenretaddr.v b/arm/Asmgenretaddr.v new file mode 100644 index 0000000..72d855a --- /dev/null +++ b/arm/Asmgenretaddr.v @@ -0,0 +1,201 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Predictor for return addresses in generated PPC code. + + The [return_address_offset] predicate defined here is used in the + concrete semantics for Mach (module [Machconcr]) to determine the + return addresses that are stored in activation records. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import Asm. +Require Import Asmgen. + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +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. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. omega. +Qed. + +(** 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 PPC code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + PPC code | |--------| + PPC function |--------------- Pbl ---------| + + <-------- ofs -------> +>> +*) + +Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop := + | return_address_offset_intro: + forall c f ofs, + code_tail ofs (transl_function f) (transl_code f c) -> + return_address_offset f c (Int.repr ofs). + +(** We now show that such an offset always exists if the Mach code [c] + is a suffix of [f.(fn_code)]. This holds because the translation + from Mach to PPC is compositional: each Mach instruction becomes + zero, one or several PPC instructions, but the order of instructions + is preserved. *) + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1. exists 0; constructor. + destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto. +Qed. + +Hint Resolve is_tail_refl: ppcretaddr. + +Ltac IsTail := + auto with ppcretaddr; + match goal with + | [ |- is_tail _ (_ :: _) ] => constructor; IsTail + | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail + | _ => idtac + end. + +Lemma loadimm_tail: + forall r n k, is_tail k (loadimm r n k). +Proof. unfold loadimm; intros; IsTail. Qed. +Hint Resolve loadimm_tail: ppcretaddr. + +Lemma addimm_tail: + forall r1 r2 n k, is_tail k (addimm r1 r2 n k). +Proof. unfold addimm; intros; IsTail. Qed. +Hint Resolve addimm_tail: ppcretaddr. + +Lemma andimm_tail: + forall r1 r2 n k, is_tail k (andimm r1 r2 n k). +Proof. unfold andimm; intros; IsTail. Qed. +Hint Resolve andimm_tail: ppcretaddr. + +Lemma makeimm_tail: + forall f r1 r2 n k, is_tail k (makeimm f r1 r2 n k). +Proof. unfold makeimm; intros; IsTail. Qed. +Hint Resolve makeimm_tail: ppcretaddr. + +Lemma transl_cond_tail: + forall cond args k, is_tail k (transl_cond cond args k). +Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed. +Hint Resolve transl_cond_tail: ppcretaddr. + +Lemma transl_op_tail: + forall op args r k, is_tail k (transl_op op args r k). +Proof. unfold transl_op; intros; destruct op; IsTail. Qed. +Hint Resolve transl_op_tail: ppcretaddr. + +Lemma transl_load_store_tail: + forall mk1 mk2 is_immed addr args k, + is_tail k (transl_load_store mk1 mk2 is_immed addr args k). +Proof. unfold transl_load_store; intros; destruct addr; IsTail. + destruct mk2; IsTail. destruct mk2; IsTail. Qed. +Hint Resolve transl_load_store_tail: ppcretaddr. + +Lemma transl_load_store_int_tail: + forall mk is_immed rd addr args k, + is_tail k (transl_load_store_int mk is_immed rd addr args k). +Proof. unfold transl_load_store_int; intros; IsTail. Qed. +Hint Resolve transl_load_store_int_tail: ppcretaddr. + +Lemma transl_load_store_float_tail: + forall mk is_immed rd addr args k, + is_tail k (transl_load_store_float mk is_immed rd addr args k). +Proof. unfold transl_load_store_float; intros; IsTail. Qed. +Hint Resolve transl_load_store_float_tail: ppcretaddr. + +Lemma loadind_int_tail: + forall base ofs dst k, is_tail k (loadind_int base ofs dst k). +Proof. unfold loadind_int; intros; IsTail. Qed. +Hint Resolve loadind_int_tail: ppcretaddr. + +Lemma loadind_tail: + forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k). +Proof. unfold loadind, loadind_float; intros; IsTail. Qed. +Hint Resolve loadind_tail: ppcretaddr. + +Lemma storeind_int_tail: + forall src base ofs k, is_tail k (storeind_int src base ofs k). +Proof. unfold storeind_int; intros; IsTail. Qed. +Hint Resolve storeind_int_tail: ppcretaddr. + +Lemma storeind_tail: + forall src base ofs ty k, is_tail k (storeind src base ofs ty k). +Proof. unfold storeind, storeind_float; intros; IsTail. Qed. +Hint Resolve storeind_tail: ppcretaddr. + +Lemma transl_instr_tail: + forall f i k, is_tail k (transl_instr f i k). +Proof. + unfold transl_instr; intros; destruct i; IsTail. + destruct m; IsTail. + destruct m; IsTail. + destruct s0; IsTail. + destruct s0; IsTail. +Qed. +Hint Resolve transl_instr_tail: ppcretaddr. + +Lemma transl_code_tail: + forall f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f c2). +Proof. + induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr. +Qed. + +Lemma return_address_exists: + forall f c, is_tail c f.(fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. assert (is_tail (transl_code f c) (transl_function f)). + unfold transl_function. IsTail. apply transl_code_tail; auto. + destruct (is_tail_code_tail _ _ H0) as [ofs A]. + exists (Int.repr ofs). constructor. auto. +Qed. + + diff --git a/arm/Constprop.v b/arm/Constprop.v new file mode 100644 index 0000000..7369012 --- /dev/null +++ b/arm/Constprop.v @@ -0,0 +1,1254 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Constant propagation over RTL. This is the first of the two + optimizations performed at RTL level. It proceeds by a standard + dataflow analysis and the corresponding code transformation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. + +(** * Static analysis *) + +(** To each pseudo-register at each program point, the static analysis + associates a compile-time approximation taken from the following set. *) + +Inductive approx : Set := + | Novalue: approx (** No value possible, code is unreachable. *) + | Unknown: approx (** All values are possible, + no compile-time information is available. *) + | I: int -> approx (** A known integer value. *) + | F: float -> approx (** A known floating-point value. *) + | S: ident -> int -> approx. + (** The value is the address of the given global + symbol plus the given integer offset. *) + +(** We equip this set of approximations with a semi-lattice structure. + The ordering is inclusion between the sets of values denoted by + the approximations. *) + +Module Approx <: SEMILATTICE_WITH_TOP. + Definition t := approx. + Definition eq (x y: t) := (x = y). + Definition eq_refl: forall x, eq x x := (@refl_equal t). + Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). + Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). + Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. + Proof. + decide equality. + apply Int.eq_dec. + apply Float.eq_dec. + apply Int.eq_dec. + apply ident_eq. + Qed. + Definition beq (x y: t) := if eq_dec x y then true else false. + Lemma beq_correct: forall x y, beq x y = true -> x = y. + Proof. + unfold beq; intros. destruct (eq_dec x y). auto. congruence. + Qed. + Definition ge (x y: t) : Prop := + x = Unknown \/ y = Novalue \/ x = y. + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge; tauto. + Qed. + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge; intuition congruence. + Qed. + Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. + Proof. + unfold eq, ge; intros; congruence. + Qed. + Definition bot := Novalue. + Definition top := Unknown. + Lemma ge_bot: forall x, ge x bot. + Proof. + unfold ge, bot; tauto. + Qed. + Lemma ge_top: forall x, ge top x. + Proof. + unfold ge, bot; tauto. + Qed. + Definition lub (x y: t) : t := + if eq_dec x y then x else + match x, y with + | Novalue, _ => y + | _, Novalue => x + | _, _ => Unknown + end. + Lemma lub_commut: forall x y, eq (lub x y) (lub y x). + Proof. + unfold lub, eq; intros. + case (eq_dec x y); case (eq_dec y x); intros; try congruence. + destruct x; destruct y; auto. + Qed. + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold lub; intros. + case (eq_dec x y); intro. + apply ge_refl. apply eq_refl. + destruct x; destruct y; unfold ge; tauto. + Qed. +End Approx. + +Module D := LPMap Approx. + +(** We now define the abstract interpretations of conditions and operators + over this set of approximations. For instance, the abstract interpretation + of the operator [Oaddf] applied to two expressions [a] and [b] is + [F(Float.add f g)] if [a] and [b] have static approximations [F f] + and [F g] respectively, and [Unknown] otherwise. + + The static approximations are defined by large pattern-matchings over + the approximations of the results. We write these matchings in the + indirect style described in file [Selection] to avoid excessive + duplication of cases in proofs. *) + +(* +Definition eval_static_condition (cond: condition) (vl: list approx) := + match cond, vl with + | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) + | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) + | Ccompshift c s, I n1 :: I n2 :: nil => Some(Int.cmp c n1 (eval_shift s n2)) + | Ccompushift c s, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 (eval_shift s n2)) + | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) + | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) + | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) + | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) + | _, _ => None + end. +*) + +Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set := + | eval_static_condition_case1: + forall c n1 n2, + eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: + forall c n1 n2, + eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: + forall c s n1 n2, + eval_static_condition_cases (Ccompshift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case4: + forall c s n1 n2, + eval_static_condition_cases (Ccompushift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case5: + forall c n n1, + eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case6: + forall c n n1, + eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case7: + forall c n1 n2, + eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case8: + forall c n1 n2, + eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_default: + forall (cond: condition) (vl: list approx), + eval_static_condition_cases cond vl. + +Definition eval_static_condition_match (cond: condition) (vl: list approx) := + match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with + | Ccomp c, I n1 :: I n2 :: nil => + eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => + eval_static_condition_case2 c n1 n2 + | Ccompshift c s, I n1 :: I n2 :: nil => + eval_static_condition_case3 c s n1 n2 + | Ccompushift c s, I n1 :: I n2 :: nil => + eval_static_condition_case4 c s n1 n2 + | Ccompimm c n, I n1 :: nil => + eval_static_condition_case5 c n n1 + | Ccompuimm c n, I n1 :: nil => + eval_static_condition_case6 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => + eval_static_condition_case7 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => + eval_static_condition_case8 c n1 n2 + | cond, vl => + eval_static_condition_default cond vl + end. + +Definition eval_static_condition (cond: condition) (vl: list approx) := + match eval_static_condition_match cond vl with + | eval_static_condition_case1 c n1 n2 => + Some(Int.cmp c n1 n2) + | eval_static_condition_case2 c n1 n2 => + Some(Int.cmpu c n1 n2) + | eval_static_condition_case3 c s n1 n2 => + Some(Int.cmp c n1 (eval_shift s n2)) + | eval_static_condition_case4 c s n1 n2 => + Some(Int.cmpu c n1 (eval_shift s n2)) + | eval_static_condition_case5 c n n1 => + Some(Int.cmp c n1 n) + | eval_static_condition_case6 c n n1 => + Some(Int.cmpu c n1 n) + | eval_static_condition_case7 c n1 n2 => + Some(Float.cmp c n1 n2) + | eval_static_condition_case8 c n1 n2 => + Some(negb(Float.cmp c n1 n2)) + | eval_static_condition_default cond vl => + None + end. + +(* +Definition eval_static_operation (op: operation) (vl: list approx) := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Ofloatconst n, nil => F n + | Oaddrsymbol s n, nil => S s n + | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) + | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) + | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) + | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) + | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) + | Oaddshift s, I n1 :: I n2 :: nil => I(Int.add n1 (eval_shift s n2)) + | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) + | Oaddshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 (eval_shift s n2)) + | Oaddimm n, I n1 :: nil => I (Int.add n1 n) + | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) + | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) + | Osubshift s, I n1 :: I n2 :: nil => I(Int.sub n1 (eval_shift s n2)) + | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) + | Osubshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 (eval_shift s n2)) + | Orsubshift s, I n1 :: I n2 :: nil => I(Int.sub (eval_shift s n2) n1) + | Orsubimm n, I n1 :: nil => I (Int.sub n n1) + | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) + | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) + | Oandshift s, I n1 :: I n2 :: nil => I(Int.and n1 (eval_shift s n2)) + | Oandimm n, I n1 :: nil => I(Int.and n1 n) + | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) + | Oorshift s, I n1 :: I n2 :: nil => I(Int.or n1 (eval_shift s n2)) + | Oorimm n, I n1 :: nil => I(Int.or n1 n) + | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) + | Oxorshift s, I n1 :: I n2 :: nil => I(Int.xor n1 (eval_shift s n2)) + | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) + | Obic, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not n2)) + | Obicshift s, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not (eval_shift s n2))) + | Onot, I n1 :: nil => I(Int.not n1) + | Onotshift s, I n1 :: nil => I(Int.not (eval_shift s n1)) + | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | Oshift s, I n1 :: nil => I(eval_shift s n1) + | Onegf, F n1 :: nil => F(Float.neg n1) + | Oabsf, F n1 :: nil => F(Float.abs n1) + | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) + | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) + | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) + | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) + | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) + | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1) + | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) + | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) + | Ocmp c, vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | _, _ => Unknown + end. +*) + +Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set := + | eval_static_operation_case1: + forall v1, + eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: + forall n, + eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: + forall n, + eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: + forall s n, + eval_static_operation_cases (Oaddrsymbol s n) (nil) + | eval_static_operation_case5: + forall n1, + eval_static_operation_cases (Ocast8signed) (I n1 :: nil) + | eval_static_operation_case6: + forall n1, + eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case7: + forall n1, + eval_static_operation_cases (Ocast16signed) (I n1 :: nil) + | eval_static_operation_case8: + forall n1, + eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) + | eval_static_operation_case9: + forall n1 n2, + eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) + | eval_static_operation_case10: + forall s n1 n2, + eval_static_operation_cases (Oaddshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case11: + forall s1 n1 n2, + eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case12: + forall s s1 n1 n2, + eval_static_operation_cases (Oaddshift s) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case13: + forall n n1, + eval_static_operation_cases (Oaddimm n) (I n1 :: nil) + | eval_static_operation_case14: + forall n s1 n1, + eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) + | eval_static_operation_case15: + forall n1 n2, + eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case16: + forall s n1 n2, + eval_static_operation_cases (Osubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case17: + forall s1 n1 n2, + eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case18: + forall s s1 n1 n2, + eval_static_operation_cases (Osubshift s) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case19: + forall s n1 n2, + eval_static_operation_cases (Orsubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case20: + forall n n1, + eval_static_operation_cases (Orsubimm n) (I n1 :: nil) + | eval_static_operation_case21: + forall n1 n2, + eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case22: + forall n1 n2, + eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case23: + forall n1 n2, + eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case24: + forall n1 n2, + eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case25: + forall s n1 n2, + eval_static_operation_cases (Oandshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case26: + forall n n1, + eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case27: + forall n1 n2, + eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case28: + forall s n1 n2, + eval_static_operation_cases (Oorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: + forall n n1, + eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case30: + forall n1 n2, + eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case31: + forall s n1 n2, + eval_static_operation_cases (Oxorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case32: + forall n n1, + eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case33: + forall n1 n2, + eval_static_operation_cases (Obic) (I n1 :: I n2 :: nil) + | eval_static_operation_case34: + forall s n1 n2, + eval_static_operation_cases (Obicshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case35: + forall n1, + eval_static_operation_cases (Onot) (I n1 :: nil) + | eval_static_operation_case36: + forall s n1, + eval_static_operation_cases (Onotshift s) (I n1 :: nil) + | eval_static_operation_case37: + forall n1 n2, + eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case38: + forall n1 n2, + eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case39: + forall n1 n2, + eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case40: + forall s n1, + eval_static_operation_cases (Oshift s) (I n1 :: nil) + | eval_static_operation_case41: + forall n1, + eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case42: + forall n1, + eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case43: + forall n1 n2, + eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case44: + forall n1 n2, + eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case45: + forall n1 n2, + eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case46: + forall n1 n2, + eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case47: + forall n1, + eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case48: + forall n1, + eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case49: + forall n1, + eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case50: + forall n1, + eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) + | eval_static_operation_case51: + forall c vl, + eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_case52: + forall n n1, + eval_static_operation_cases (Oshrximm n) (I n1 :: nil) + | eval_static_operation_default: + forall (op: operation) (vl: list approx), + eval_static_operation_cases op vl. + +Definition eval_static_operation_match (op: operation) (vl: list approx) := + match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with + | Omove, v1::nil => + eval_static_operation_case1 v1 + | Ointconst n, nil => + eval_static_operation_case2 n + | Ofloatconst n, nil => + eval_static_operation_case3 n + | Oaddrsymbol s n, nil => + eval_static_operation_case4 s n + | Ocast8signed, I n1 :: nil => + eval_static_operation_case5 n1 + | Ocast8unsigned, I n1 :: nil => + eval_static_operation_case6 n1 + | Ocast16signed, I n1 :: nil => + eval_static_operation_case7 n1 + | Ocast16unsigned, I n1 :: nil => + eval_static_operation_case8 n1 + | Oadd, I n1 :: I n2 :: nil => + eval_static_operation_case9 n1 n2 + | Oaddshift s, I n1 :: I n2 :: nil => + eval_static_operation_case10 s n1 n2 + | Oadd, S s1 n1 :: I n2 :: nil => + eval_static_operation_case11 s1 n1 n2 + | Oaddshift s, S s1 n1 :: I n2 :: nil => + eval_static_operation_case12 s s1 n1 n2 + | Oaddimm n, I n1 :: nil => + eval_static_operation_case13 n n1 + | Oaddimm n, S s1 n1 :: nil => + eval_static_operation_case14 n s1 n1 + | Osub, I n1 :: I n2 :: nil => + eval_static_operation_case15 n1 n2 + | Osubshift s, I n1 :: I n2 :: nil => + eval_static_operation_case16 s n1 n2 + | Osub, S s1 n1 :: I n2 :: nil => + eval_static_operation_case17 s1 n1 n2 + | Osubshift s, S s1 n1 :: I n2 :: nil => + eval_static_operation_case18 s s1 n1 n2 + | Orsubshift s, I n1 :: I n2 :: nil => + eval_static_operation_case19 s n1 n2 + | Orsubimm n, I n1 :: nil => + eval_static_operation_case20 n n1 + | Omul, I n1 :: I n2 :: nil => + eval_static_operation_case21 n1 n2 + | Odiv, I n1 :: I n2 :: nil => + eval_static_operation_case22 n1 n2 + | Odivu, I n1 :: I n2 :: nil => + eval_static_operation_case23 n1 n2 + | Oand, I n1 :: I n2 :: nil => + eval_static_operation_case24 n1 n2 + | Oandshift s, I n1 :: I n2 :: nil => + eval_static_operation_case25 s n1 n2 + | Oandimm n, I n1 :: nil => + eval_static_operation_case26 n n1 + | Oor, I n1 :: I n2 :: nil => + eval_static_operation_case27 n1 n2 + | Oorshift s, I n1 :: I n2 :: nil => + eval_static_operation_case28 s n1 n2 + | Oorimm n, I n1 :: nil => + eval_static_operation_case29 n n1 + | Oxor, I n1 :: I n2 :: nil => + eval_static_operation_case30 n1 n2 + | Oxorshift s, I n1 :: I n2 :: nil => + eval_static_operation_case31 s n1 n2 + | Oxorimm n, I n1 :: nil => + eval_static_operation_case32 n n1 + | Obic, I n1 :: I n2 :: nil => + eval_static_operation_case33 n1 n2 + | Obicshift s, I n1 :: I n2 :: nil => + eval_static_operation_case34 s n1 n2 + | Onot, I n1 :: nil => + eval_static_operation_case35 n1 + | Onotshift s, I n1 :: nil => + eval_static_operation_case36 s n1 + | Oshl, I n1 :: I n2 :: nil => + eval_static_operation_case37 n1 n2 + | Oshr, I n1 :: I n2 :: nil => + eval_static_operation_case38 n1 n2 + | Oshru, I n1 :: I n2 :: nil => + eval_static_operation_case39 n1 n2 + | Oshift s, I n1 :: nil => + eval_static_operation_case40 s n1 + | Onegf, F n1 :: nil => + eval_static_operation_case41 n1 + | Oabsf, F n1 :: nil => + eval_static_operation_case42 n1 + | Oaddf, F n1 :: F n2 :: nil => + eval_static_operation_case43 n1 n2 + | Osubf, F n1 :: F n2 :: nil => + eval_static_operation_case44 n1 n2 + | Omulf, F n1 :: F n2 :: nil => + eval_static_operation_case45 n1 n2 + | Odivf, F n1 :: F n2 :: nil => + eval_static_operation_case46 n1 n2 + | Osingleoffloat, F n1 :: nil => + eval_static_operation_case47 n1 + | Ointoffloat, F n1 :: nil => + eval_static_operation_case48 n1 + | Ofloatofint, I n1 :: nil => + eval_static_operation_case49 n1 + | Ofloatofintu, I n1 :: nil => + eval_static_operation_case50 n1 + | Ocmp c, vl => + eval_static_operation_case51 c vl + | Oshrximm n, I n1 :: nil => + eval_static_operation_case52 n n1 + | op, vl => + eval_static_operation_default op vl + end. + +Definition eval_static_operation (op: operation) (vl: list approx) := + match eval_static_operation_match op vl with + | eval_static_operation_case1 v1 => + v1 + | eval_static_operation_case2 n => + I n + | eval_static_operation_case3 n => + F n + | eval_static_operation_case4 s n => + S s n + | eval_static_operation_case5 n => + I(Int.sign_ext 8 n) + | eval_static_operation_case6 n => + I(Int.zero_ext 8 n) + | eval_static_operation_case7 n => + I(Int.sign_ext 16 n) + | eval_static_operation_case8 n => + I(Int.zero_ext 16 n) + | eval_static_operation_case9 n1 n2 => + I(Int.add n1 n2) + | eval_static_operation_case10 s n1 n2 => + I(Int.add n1 (eval_shift s n2)) + | eval_static_operation_case11 s1 n1 n2 => + S s1 (Int.add n1 n2) + | eval_static_operation_case12 s s1 n1 n2 => + S s1 (Int.add n1 (eval_shift s n2)) + | eval_static_operation_case13 n n1 => + I (Int.add n1 n) + | eval_static_operation_case14 n s1 n1 => + S s1 (Int.add n1 n) + | eval_static_operation_case15 n1 n2 => + I(Int.sub n1 n2) + | eval_static_operation_case16 s n1 n2 => + I(Int.sub n1 (eval_shift s n2)) + | eval_static_operation_case17 s1 n1 n2 => + S s1 (Int.sub n1 n2) + | eval_static_operation_case18 s s1 n1 n2 => + S s1 (Int.sub n1 (eval_shift s n2)) + | eval_static_operation_case19 s n1 n2 => + I(Int.sub (eval_shift s n2) n1) + | eval_static_operation_case20 n n1 => + I (Int.sub n n1) + | eval_static_operation_case21 n1 n2 => + I(Int.mul n1 n2) + | eval_static_operation_case22 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | eval_static_operation_case23 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | eval_static_operation_case24 n1 n2 => + I(Int.and n1 n2) + | eval_static_operation_case25 s n1 n2 => + I(Int.and n1 (eval_shift s n2)) + | eval_static_operation_case26 n n1 => + I(Int.and n1 n) + | eval_static_operation_case27 n1 n2 => + I(Int.or n1 n2) + | eval_static_operation_case28 s n1 n2 => + I(Int.or n1 (eval_shift s n2)) + | eval_static_operation_case29 n n1 => + I(Int.or n1 n) + | eval_static_operation_case30 n1 n2 => + I(Int.xor n1 n2) + | eval_static_operation_case31 s n1 n2 => + I(Int.xor n1 (eval_shift s n2)) + | eval_static_operation_case32 n n1 => + I(Int.xor n1 n) + | eval_static_operation_case33 n1 n2 => + I(Int.and n1 (Int.not n2)) + | eval_static_operation_case34 s n1 n2 => + I(Int.and n1 (Int.not (eval_shift s n2))) + | eval_static_operation_case35 n1 => + I(Int.not n1) + | eval_static_operation_case36 s n1 => + I(Int.not (eval_shift s n1)) + | eval_static_operation_case37 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | eval_static_operation_case38 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | eval_static_operation_case39 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | eval_static_operation_case40 s n1 => + I(eval_shift s n1) + | eval_static_operation_case41 n1 => + F(Float.neg n1) + | eval_static_operation_case42 n1 => + F(Float.abs n1) + | eval_static_operation_case43 n1 n2 => + F(Float.add n1 n2) + | eval_static_operation_case44 n1 n2 => + F(Float.sub n1 n2) + | eval_static_operation_case45 n1 n2 => + F(Float.mul n1 n2) + | eval_static_operation_case46 n1 n2 => + F(Float.div n1 n2) + | eval_static_operation_case47 n1 => + F(Float.singleoffloat n1) + | eval_static_operation_case48 n1 => + I(Float.intoffloat n1) + | eval_static_operation_case49 n1 => + F(Float.floatofint n1) + | eval_static_operation_case50 n1 => + F(Float.floatofintu n1) + | eval_static_operation_case51 c vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | eval_static_operation_case52 n n1 => + if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown + | eval_static_operation_default op vl => + Unknown + end. + + +(** The transfer function for the dataflow analysis is straightforward: + for [Iop] instructions, we set the approximation of the destination + register to the result of executing abstractly the operation; + for [Iload] and [Icall], we set the approximation of the destination + to [Unknown]. *) + +Definition approx_regs (rl: list reg) (approx: D.t) := + List.map (fun r => D.get r approx) rl. + +Definition transfer (f: function) (pc: node) (before: D.t) := + match f.(fn_code)!pc with + | None => before + | Some i => + match i with + | Inop s => + before + | Iop op args res s => + let a := eval_static_operation op (approx_regs args before) in + D.set res a before + | Iload chunk addr args dst s => + D.set dst Unknown before + | Istore chunk addr args src s => + before + | Icall sig ros args res s => + D.set res Unknown before + | Itailcall sig ros args => + before + | Ialloc arg res s => + D.set res Unknown before + | Icond cond args ifso ifnot => + before + | Ireturn optarg => + before + end + end. + +(** The static analysis itself is then an instantiation of Kildall's + generic solver for forward dataflow inequations. [analyze f] + returns a mapping from program points to mappings of pseudo-registers + to approximations. It can fail to reach a fixpoint in a reasonable + number of iterations, in which case [None] is returned. *) + +Module DS := Dataflow_Solver(D)(NodeSetForward). + +Definition analyze (f: RTL.function): PMap.t D.t := + match DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) + ((f.(fn_entrypoint), D.top) :: nil) with + | None => PMap.init D.top + | Some res => res + end. + +(** * Code transformation *) + +(** ** 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. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. + +Definition intval (r: reg) : option int := + match D.get r approx with I n => Some n | _ => None end. + +(* +Definition cond_strength_reduction (cond: condition) (args: list reg) := + match cond, args with + | Ccomp c, r1 :: r2 :: nil => + | Ccompu c, r1 :: r2 :: nil => + | Ccompshift c s, r1 :: r2 :: nil => + | Ccompushift c s, r1 :: r2 :: nil => + | _ => + end. +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg), Set := + | cond_strength_reduction_case1: + forall c r1 r2, + cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) + | cond_strength_reduction_case2: + forall c r1 r2, + cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) + | cond_strength_reduction_case3: + forall c s r1 r2, + cond_strength_reduction_cases (Ccompshift c s) (r1 :: r2 :: nil) + | cond_strength_reduction_case4: + forall c s r1 r2, + cond_strength_reduction_cases (Ccompushift c s) (r1 :: r2 :: nil) + | cond_strength_reduction_default: + forall (cond: condition) (args: list reg), + cond_strength_reduction_cases cond args. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) := + match cond as z1, args as z2 return cond_strength_reduction_cases z1 z2 with + | Ccomp c, r1 :: r2 :: nil => + cond_strength_reduction_case1 c r1 r2 + | Ccompu c, r1 :: r2 :: nil => + cond_strength_reduction_case2 c r1 r2 + | Ccompshift c s, r1 :: r2 :: nil => + cond_strength_reduction_case3 c s r1 r2 + | Ccompushift c s, r1 :: r2 :: nil => + cond_strength_reduction_case4 c s r1 r2 + | cond, args => + cond_strength_reduction_default cond args + end. + +Definition cond_strength_reduction (cond: condition) (args: list reg) := + match cond_strength_reduction_match cond args with + | cond_strength_reduction_case1 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | cond_strength_reduction_case2 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompuimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompuimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | cond_strength_reduction_case3 c s r1 r2 => + match intval r2 with + | Some n => + (Ccompimm c (eval_shift s n), r1 :: nil) + | None => + (cond, args) + end + | cond_strength_reduction_case4 c s r1 r2 => + match intval r2 with + | Some n => + (Ccompuimm c (eval_shift s n), r1 :: nil) + | None => + (cond, args) + end + | cond_strength_reduction_default cond args => + (cond, args) + 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) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Slsl n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_shrimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Sasr n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_shruimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Slsr n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_mulimm (n: int) (r: reg) (r': reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r :: nil) + else + match Int.is_power2 n with + | Some l => make_shlimm l r + | None => (Omul, r :: r' :: nil) + end. + +Definition make_andimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Onot, r :: nil) + else (Oxorimm n, r :: nil). + +(* +Definition op_strength_reduction (op: operation) (args: list reg) := + match op, args with + | Oadd, r1 :: r2 :: nil => + | Oaddshift s, r1 :: r2 :: nil => + | Osub, r1 :: r2 :: nil => + | Osubshift s, r1 :: r2 :: nil => + | Orsubshift s, r1 :: r2 :: nil => + | Omul, r1 :: r2 :: nil => + | Odivu, r1 :: r2 :: nil => + | Oand, r1 :: r2 :: nil => + | Oandshift s, r1 :: r2 :: nil => + | Oor, r1 :: r2 :: nil => + | Oorshift s, r1 :: r2 :: nil => + | Oxor, r1 :: r2 :: nil => + | Oxorshift s, r1 :: r2 :: nil => + | Obic, r1 :: r2 :: nil => + | Obicshift s, r1 :: r2 :: nil => + | Oshl, r1 :: r2 :: nil => + | Oshr, r1 :: r2 :: nil => + | Oshru, r1 :: r2 :: nil => + | Ocmp c, rl => + | _, _ => + end. +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Set := + | op_strength_reduction_case1: + forall r1 r2, + op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) + | op_strength_reduction_case2: + forall s r1 r2, + op_strength_reduction_cases (Oaddshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case3: + forall r1 r2, + op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) + | op_strength_reduction_case4: + forall s r1 r2, + op_strength_reduction_cases (Osubshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case5: + forall s r1 r2, + op_strength_reduction_cases (Orsubshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case6: + forall r1 r2, + op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) + | op_strength_reduction_case7: + forall r1 r2, + op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) + | op_strength_reduction_case8: + forall r1 r2, + op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) + | op_strength_reduction_case9: + forall s r1 r2, + op_strength_reduction_cases (Oandshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case10: + forall r1 r2, + op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) + | op_strength_reduction_case11: + forall s r1 r2, + op_strength_reduction_cases (Oorshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case12: + forall r1 r2, + op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) + | op_strength_reduction_case13: + forall s r1 r2, + op_strength_reduction_cases (Oxorshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case14: + forall r1 r2, + op_strength_reduction_cases (Obic) (r1 :: r2 :: nil) + | op_strength_reduction_case15: + forall s r1 r2, + op_strength_reduction_cases (Obicshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case16: + forall r1 r2, + op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) + | op_strength_reduction_case17: + forall r1 r2, + op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) + | op_strength_reduction_case18: + forall r1 r2, + op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) + | op_strength_reduction_case19: + forall c rl, + op_strength_reduction_cases (Ocmp c) rl + | op_strength_reduction_default: + forall (op: operation) (args: list reg), + op_strength_reduction_cases op args. + +Definition op_strength_reduction_match (op: operation) (args: list reg) := + match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with + | Oadd, r1 :: r2 :: nil => + op_strength_reduction_case1 r1 r2 + | Oaddshift s, r1 :: r2 :: nil => + op_strength_reduction_case2 s r1 r2 + | Osub, r1 :: r2 :: nil => + op_strength_reduction_case3 r1 r2 + | Osubshift s, r1 :: r2 :: nil => + op_strength_reduction_case4 s r1 r2 + | Orsubshift s, r1 :: r2 :: nil => + op_strength_reduction_case5 s r1 r2 + | Omul, r1 :: r2 :: nil => + op_strength_reduction_case6 r1 r2 + | Odivu, r1 :: r2 :: nil => + op_strength_reduction_case7 r1 r2 + | Oand, r1 :: r2 :: nil => + op_strength_reduction_case8 r1 r2 + | Oandshift s, r1 :: r2 :: nil => + op_strength_reduction_case9 s r1 r2 + | Oor, r1 :: r2 :: nil => + op_strength_reduction_case10 r1 r2 + | Oorshift s, r1 :: r2 :: nil => + op_strength_reduction_case11 s r1 r2 + | Oxor, r1 :: r2 :: nil => + op_strength_reduction_case12 r1 r2 + | Oxorshift s, r1 :: r2 :: nil => + op_strength_reduction_case13 s r1 r2 + | Obic, r1 :: r2 :: nil => + op_strength_reduction_case14 r1 r2 + | Obicshift s, r1 :: r2 :: nil => + op_strength_reduction_case15 s r1 r2 + | Oshl, r1 :: r2 :: nil => + op_strength_reduction_case16 r1 r2 + | Oshr, r1 :: r2 :: nil => + op_strength_reduction_case17 r1 r2 + | Oshru, r1 :: r2 :: nil => + op_strength_reduction_case18 r1 r2 + | Ocmp c, rl => + op_strength_reduction_case19 c rl + | op, args => + op_strength_reduction_default op args + end. + +Definition op_strength_reduction (op: operation) (args: list reg) := + match op_strength_reduction_match op args with + | op_strength_reduction_case1 r1 r2 => (* Oadd *) + match intval r1, intval r2 with + | Some n, _ => make_addimm n r2 + | _, Some n => make_addimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case2 s r1 r2 => (* Oaddshift *) + match intval r2 with + | Some n => make_addimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case3 r1 r2 => (* Osub *) + match intval r1, intval r2 with + | Some n, _ => (Orsubimm n, r2 :: nil) + | _, Some n => make_addimm (Int.neg n) r1 + | _, _ => (op, args) + end + | op_strength_reduction_case4 s r1 r2 => (* Osubshift *) + match intval r2 with + | Some n => make_addimm (Int.neg (eval_shift s n)) r1 + | _ => (op, args) + end + | op_strength_reduction_case5 s r1 r2 => (* Orsubshift *) + match intval r2 with + | Some n => (Orsubimm (eval_shift s n), r1 :: nil) + | _ => (op, args) + end + | op_strength_reduction_case6 r1 r2 => (* Omul *) + match intval r1, intval r2 with + | Some n, _ => make_mulimm n r2 r1 + | _, Some n => make_mulimm n r1 r2 + | _, _ => (op, args) + end + | op_strength_reduction_case7 r1 r2 => (* Odivu *) + match intval r2 with + | Some n => + match Int.is_power2 n with + | Some l => make_shruimm l r1 + | None => (op, args) + end + | None => + (op, args) + end + | op_strength_reduction_case8 r1 r2 => (* Oand *) + match intval r1, intval r2 with + | Some n, _ => make_andimm n r2 + | _, Some n => make_andimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case9 s r1 r2 => (* Oandshift *) + match intval r2 with + | Some n => make_andimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case10 r1 r2 => (* Oor *) + match intval r1, intval r2 with + | Some n, _ => make_orimm n r2 + | _, Some n => make_orimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case11 s r1 r2 => (* Oorshift *) + match intval r2 with + | Some n => make_orimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case12 r1 r2 => (* Oxor *) + match intval r1, intval r2 with + | Some n, _ => make_xorimm n r2 + | _, Some n => make_xorimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case13 s r1 r2 => (* Oxorshift *) + match intval r2 with + | Some n => make_xorimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case14 r1 r2 => (* Obic *) + match intval r2 with + | Some n => make_andimm (Int.not n) r1 + | _ => (op, args) + end + | op_strength_reduction_case15 s r1 r2 => (* Obicshift *) + match intval r2 with + | Some n => make_andimm (Int.not (eval_shift s n)) r1 + | _ => (op, args) + end + | op_strength_reduction_case16 r1 r2 => (* Oshl *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shlimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case17 r1 r2 => (* Oshr *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shrimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case18 r1 r2 => (* Oshru *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shruimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case19 c rl => (* Ocmp *) + let (c', args') := cond_strength_reduction c args in + (Ocmp c', args') + | op_strength_reduction_default op args => (* default *) + (op, args) + end. + +(* +Definition addr_strength_reduction (addr: addressing) (args: list reg) := + match addr, args with + | Aindexed2, r1 :: r2 :: nil => + | Aindexed2shift s, r1 :: r2 :: nil => + | _, _ => + end. +*) + +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set := + | addr_strength_reduction_case1: + forall r1 r2, + addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) + | addr_strength_reduction_case2: + forall s r1 r2, + addr_strength_reduction_cases (Aindexed2shift s) (r1 :: r2 :: nil) + | addr_strength_reduction_default: + forall (addr: addressing) (args: list reg), + addr_strength_reduction_cases addr args. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := + match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with + | Aindexed2, r1 :: r2 :: nil => + addr_strength_reduction_case1 r1 r2 + | Aindexed2shift s, r1 :: r2 :: nil => + addr_strength_reduction_case2 s r1 r2 + | addr, args => + addr_strength_reduction_default addr args + end. + +Definition addr_strength_reduction (addr: addressing) (args: list reg) := + match addr_strength_reduction_match addr args with + | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) + match intval r1, intval r2 with + | Some n1, _ => (Aindexed n1, r2 :: nil) + | _, Some n2 => (Aindexed n2, r1 :: nil) + | _, _ => (addr, args) + end + | addr_strength_reduction_case2 s r1 r2 => (* Aindexed2shift *) + match intval r2 with + | Some n2 => (Aindexed (eval_shift s n2), r1 :: nil) + | _ => (addr, args) + end + | addr_strength_reduction_default addr args => + (addr, args) + end. + +End STRENGTH_REDUCTION. + +(** ** Code transformation *) + +(** The code transformation proceeds instruction by instruction. + Operators whose arguments are all statically known are turned + into ``load integer constant'', ``load float constant'' or + ``load symbol address'' operations. Operators for which some + but not all arguments are known are subject to strength reduction, + and similarly for the addressing modes of load and store instructions. + Other instructions are unchanged. *) + +Definition transf_ros (approx: D.t) (ros: reg + ident) : reg + ident := + match ros with + | inl r => + match D.get r approx with + | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros + | _ => ros + end + | inr s => ros + end. + +Definition transf_instr (approx: D.t) (instr: instruction) := + match instr with + | Iop op args res s => + match eval_static_operation op (approx_regs args approx) with + | I n => + Iop (Ointconst n) nil res s + | F n => + Iop (Ofloatconst n) nil res s + | S symb ofs => + Iop (Oaddrsymbol symb ofs) nil res s + | _ => + let (op', args') := op_strength_reduction approx op args in + Iop op' args' res s + end + | Iload chunk addr args dst s => + let (addr', args') := addr_strength_reduction approx addr args in + Iload chunk addr' args' dst s + | Istore chunk addr args src s => + let (addr', args') := addr_strength_reduction approx addr args in + Istore chunk addr' args' src s + | Icall sig ros args res s => + Icall sig (transf_ros approx ros) args res s + | Itailcall sig ros args => + Itailcall sig (transf_ros approx ros) args + | Ialloc arg res s => + Ialloc arg res s + | Icond cond args s1 s2 => + match eval_static_condition cond (approx_regs args approx) with + | Some b => + if b then Inop s1 else Inop s2 + | None => + let (cond', args') := cond_strength_reduction approx cond args in + Icond cond' args' s1 s2 + end + | _ => + instr + end. + +Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := + PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. + +Lemma transf_code_wf: + forall f approxs, + (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) -> + (forall pc, Plt pc f.(fn_nextpc) + \/ (transf_code approxs f.(fn_code))!pc = None). +Proof. + intros. + elim (H pc); intro. + left; auto. + right. unfold transf_code. rewrite PTree.gmap. + unfold option_map; rewrite H0. reflexivity. +Qed. + +Definition transf_function (f: function) : function := + let approxs := analyze f in + mkfunction + f.(fn_sig) + f.(fn_params) + f.(fn_stacksize) + (transf_code approxs f.(fn_code)) + f.(fn_entrypoint) + f.(fn_nextpc) + (transf_code_wf f approxs f.(fn_code_wf)). + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. diff --git a/arm/Constpropproof.v b/arm/Constpropproof.v new file mode 100644 index 0000000..e85cadf --- /dev/null +++ b/arm/Constpropproof.v @@ -0,0 +1,970 @@ +(* *********************************************************************) +(* *) +(* 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 constant propagation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. +Require Import Constprop. + +(** * Correctness of the static analysis *) + +Section ANALYSIS. + +Variable ge: genv. + +(** We first show that the dataflow analysis is correct with respect + to the dynamic semantics: the approximations (sets of values) + of a register at a program point predicted by the static analysis + are a superset of the values actually encountered during concrete + executions. We formalize this correspondence between run-time values and + compile-time approximations by the following predicate. *) + +Definition val_match_approx (a: approx) (v: val) : Prop := + match a with + | Unknown => True + | I p => v = Vint p + | F p => v = Vfloat p + | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | _ => False + end. + +Definition regs_match_approx (a: D.t) (rs: regset) : Prop := + forall r, val_match_approx (D.get r a) rs#r. + +Lemma regs_match_approx_top: + forall rs, regs_match_approx D.top rs. +Proof. + intros. red; intros. simpl. rewrite PTree.gempty. + unfold Approx.top, val_match_approx. auto. +Qed. + +Lemma val_match_approx_increasing: + forall a1 a2 v, + Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v. +Proof. + intros until v. + intros [A|[B|C]]. + subst a1. simpl. auto. + subst a2. simpl. tauto. + subst a2. auto. +Qed. + +Lemma regs_match_approx_increasing: + forall a1 a2 rs, + D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. +Proof. + unfold D.ge, regs_match_approx. intros. + apply val_match_approx_increasing with (D.get r a2); auto. +Qed. + +Lemma regs_match_approx_update: + forall ra rs a v r, + val_match_approx a v -> + regs_match_approx ra rs -> + regs_match_approx (D.set r a ra) (rs#r <- v). +Proof. + intros; red; intros. rewrite Regmap.gsspec. + case (peq r0 r); intro. + subst r0. rewrite D.gss. auto. + rewrite D.gso; auto. +Qed. + +Inductive val_list_match_approx: list approx -> list val -> Prop := + | vlma_nil: + val_list_match_approx nil nil + | vlma_cons: + forall a al v vl, + val_match_approx a v -> + val_list_match_approx al vl -> + val_list_match_approx (a :: al) (v :: vl). + +Lemma approx_regs_val_list: + forall ra rs rl, + regs_match_approx ra rs -> + val_list_match_approx (approx_regs rl ra) rs##rl. +Proof. + induction rl; simpl; intros. + constructor. + constructor. apply H. auto. +Qed. + +Ltac SimplVMA := + match goal with + | H: (val_match_approx (I _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (F _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _ _) ?v) |- _ => + simpl in H; + (try (elim H; + let b := fresh "b" in let A := fresh in let B := fresh in + (intros b [A B]; subst v; clear H))); + SimplVMA + | _ => + idtac + end. + +Ltac InvVLMA := + match goal with + | H: (val_list_match_approx nil ?vl) |- _ => + inversion H + | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => + inversion H; SimplVMA; InvVLMA + | _ => + idtac + end. + +(** We then show that [eval_static_operation] is a correct abstract + interpretations of [eval_operation]: if the concrete arguments match + the given approximations, the concrete results match the + approximations returned by [eval_static_operation]. *) + +Lemma eval_static_condition_correct: + forall cond al vl m b, + val_list_match_approx al vl -> + eval_static_condition cond al = Some b -> + eval_condition cond vl m = Some b. +Proof. + intros until b. + unfold eval_static_condition. + case (eval_static_condition_match cond al); intros; + InvVLMA; simpl; congruence. +Qed. + +Lemma eval_static_operation_correct: + forall op sp al vl m v, + val_list_match_approx al vl -> + eval_operation ge sp op vl m = Some v -> + val_match_approx (eval_static_operation op al) v. +Proof. + intros until v. + unfold eval_static_operation. + case (eval_static_operation_match op al); intros; + InvVLMA; simpl in *; FuncInv; try congruence. + + destruct (Genv.find_symbol ge s). exists b. intuition congruence. + congruence. + + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. + + caseEq (eval_static_condition c vl0). + intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). + intro. rewrite H2 in H0. + destruct b; injection H0; intro; subst v; simpl; auto. + intros; simpl; auto. + + replace n1 with i. destruct (Int.ltu n (Int.repr 31)). + injection H0; intro; subst v. simpl. auto. congruence. congruence. + + auto. +Qed. + +(** The correctness of the static analysis follows from the results + above and the fact that the result of the static analysis is + a solution of the forward dataflow inequations. *) + +Lemma analyze_correct_1: + forall f pc rs pc', + In pc' (successors f pc) -> + regs_match_approx (transfer f pc (analyze f)!!pc) rs -> + regs_match_approx (analyze f)!!pc' rs. +Proof. + intros until pc'. unfold analyze. + caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. + apply regs_match_approx_increasing with (transfer f pc approxs!!pc). + eapply DS.fixpoint_solution; eauto. + elim (fn_code_wf f pc); intro. auto. + unfold successors in H0; rewrite H2 in H0; simpl; contradiction. + auto. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +Lemma analyze_correct_3: + forall f rs, + regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. +Proof. + intros. unfold analyze. + caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. + apply regs_match_approx_increasing with D.top. + eapply DS.fixpoint_entry; eauto. auto with coqlib. + apply regs_match_approx_top. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +(** * Correctness of strength reduction *) + +(** We now show that strength reduction over operators and addressing + modes preserve semantics: the strength-reduced operations and + addressings evaluate to the same values as the original ones if the + actual arguments match the static approximations used for strength + reduction. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. +Variable sp: val. +Variable rs: regset. +Hypothesis MATCH: regs_match_approx approx rs. + +Lemma intval_correct: + forall r n, + intval approx r = Some n -> rs#r = Vint n. +Proof. + intros until n. + unfold intval. caseEq (D.get r approx); intros; try discriminate. + generalize (MATCH r). unfold val_match_approx. rewrite H. + congruence. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args m, + let (cond', args') := cond_strength_reduction approx cond args in + eval_condition cond' rs##args' m = eval_condition cond rs##args m. +Proof. + intros. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args); intros. + + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. + destruct c; reflexivity. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H). auto. + auto. + + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H). auto. + auto. + + auto. +Qed. + +Lemma make_addimm_correct: + forall n r m v, + let (op, args) := make_addimm n r in + eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_addimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. + rewrite Int.add_zero in H. congruence. + exact H0. +Qed. + +Lemma make_shlimm_correct: + forall n r m v, + let (op, args) := make_shlimm n r in + eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_shlimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_shrimm_correct: + forall n r m v, + let (op, args) := make_shrimm n r in + eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_shrimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_shruimm_correct: + forall n r m v, + let (op, args) := make_shruimm n r in + eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_shruimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_mulimm_correct: + forall n r r' m v, + rs#r' = Vint n -> + let (op, args) := make_mulimm n r r' in + eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_mulimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in H1. FuncInv. rewrite Int.mul_zero in H0. simpl. congruence. + generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. + subst n. simpl in H2. simpl. FuncInv. rewrite Int.mul_one in H1. congruence. + caseEq (Int.is_power2 n); intros. + replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) + with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). + apply make_shlimm_correct. + simpl. generalize (Int.is_power2_range _ _ H2). + change (Z_of_nat wordsize) with 32. intro. rewrite H3. + destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H2). auto. + simpl List.map. rewrite H. auto. +Qed. + +Lemma make_andimm_correct: + forall n r m v, + let (op, args) := make_andimm n r in + eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_andimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_orimm_correct: + forall n r m v, + let (op, args) := make_orimm n r in + eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_orimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_xorimm_correct: + forall n r m v, + let (op, args) := make_xorimm n r in + eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. +Proof. + intros; unfold make_xorimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. + subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. decEq. auto. + exact H1. +Qed. + +Lemma op_strength_reduction_correct: + forall op args m v, + let (op', args') := op_strength_reduction approx op args in + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp op' rs##args' m = Some v. +Proof. + intros; unfold op_strength_reduction; + case (op_strength_reduction_match op args); intros; simpl List.map. + (* Oadd *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_addimm_correct. + assumption. + (* Oaddshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oaddshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r1; auto. + assumption. + (* Osub *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H) in H0. + simpl in *. destruct rs#r2; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). + replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. + assumption. + (* Osubshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Osubshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg (eval_shift s i)) :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. + assumption. + (* Orsubshift *) + caseEq (intval approx r2). intros n H. + rewrite (intval_correct _ _ H). + simpl. destruct rs#r1; auto. + auto. + (* Omul *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). + apply make_mulimm_correct. apply intval_correct; auto. + simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_mulimm_correct. + apply intval_correct; auto. + assumption. + (* Odivu *) + caseEq (intval approx r2); intros. + caseEq (Int.is_power2 i); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). + apply make_shruimm_correct. + simpl. destruct rs#r1; auto. + change 32 with (Z_of_nat wordsize). + rewrite (Int.is_power2_range _ _ H0). + generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. + subst i. discriminate. + rewrite (Int.divu_pow2 i1 _ _ H0). auto. + assumption. + assumption. + (* Oand *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). + apply make_andimm_correct. + simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_andimm_correct. + assumption. + (* Oandshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oandshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Oor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). + apply make_orimm_correct. + simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_orimm_correct. + assumption. + (* Oorshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oor (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_orimm_correct. reflexivity. + assumption. + (* Oxor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). + apply make_xorimm_correct. + simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_xorimm_correct. + assumption. + (* Oxorshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oxorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oxor (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_xorimm_correct. reflexivity. + assumption. + (* Obic *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Obic (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not i) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Obicshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Obicshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not (eval_shift s i)) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Oshl *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shlimm_correct. + assumption. + assumption. + (* Oshr *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shrimm_correct. + assumption. + assumption. + (* Oshru *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shruimm_correct. + assumption. + assumption. + (* Ocmp *) + generalize (cond_strength_reduction_correct c rl). + destruct (cond_strength_reduction approx c rl). + simpl. intro. rewrite H. auto. + (* default *) + assumption. +Qed. + +Ltac KnownApprox := + match goal with + | MATCH: (regs_match_approx ?approx ?rs), + H: (D.get ?r ?approx = ?a) |- _ => + generalize (MATCH r); rewrite H; intro; clear H; KnownApprox + | _ => idtac + end. + +Lemma addr_strength_reduction_correct: + forall addr args, + let (addr', args') := addr_strength_reduction approx addr args in + eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. +Proof. + intros. + + unfold addr_strength_reduction; + case (addr_strength_reduction_match addr args); intros. + + (* Aindexed2 *) + caseEq (intval approx r1); intros. + simpl; rewrite (intval_correct _ _ H). + destruct rs#r2; auto. rewrite Int.add_commut; auto. + caseEq (intval approx r2); intros. + simpl; rewrite (intval_correct _ _ H0). auto. + auto. + + (* Aindexed2shift *) + caseEq (intval approx r2); intros. + simpl; rewrite (intval_correct _ _ H). auto. + auto. + + (* default *) + reflexivity. +Qed. + +End STRENGTH_REDUCTION. + +End ANALYSIS. + +(** * Correctness of the code transformation *) + +(** We now show that the transformed code after constant propagation + has the same semantics as the original code. *) + +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +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. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf transf_fundef H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf transf_fundef H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (transf_fundef f) = funsig f. +Proof. + intros. destruct f; reflexivity. +Qed. + +Lemma transf_ros_correct: + forall ros rs f approx, + regs_match_approx ge approx rs -> + find_function ge ros rs = Some f -> + find_function tge (transf_ros approx ros) rs = Some (transf_fundef f). +Proof. + intros until approx; intro MATCH. + destruct ros; simpl. + intro. + exploit functions_translated; eauto. intro FIND. + caseEq (D.get r approx); intros; auto. + generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto. + generalize (MATCH r). rewrite H0. intros [b [A B]]. + rewrite <- symbols_preserved in A. + rewrite B in FIND. rewrite H1 in FIND. + rewrite Genv.find_funct_find_funct_ptr in FIND. + simpl. rewrite A. auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + intro. apply function_ptr_translated. auto. + congruence. +Qed. + +(** The proof of semantic preservation is a simulation argument + based on diagrams of the following form: +<< + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' +>> + The left vertical arrow represents a transition in the + original RTL code. The top horizontal bar is the [match_states] + invariant between the initial state [st1] in the original RTL code + and an initial state [st2] in the transformed code. + This invariant expresses that all code fragments appearing in [st2] + are obtained by [transf_code] transformation of the corresponding + fragments in [st1]. Moreover, the values of registers in [st1] + must match their compile-time approximations at the current program + point. + These two parts of the diagram are the hypotheses. In conclusions, + we want to prove the other two parts: the right vertical arrow, + which is a transition in the transformed RTL code, and the bottom + horizontal bar, which means that the [match_state] predicate holds + between the final states [st1'] and [st2']. *) + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + match_stackframe_intro: + forall res c sp pc rs f, + c = f.(RTL.fn_code) -> + (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) -> + match_stackframes + (Stackframe res c sp pc rs) + (Stackframe res (transf_code (analyze f) c) sp pc rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s c sp pc rs m f s' + (CF: c = f.(RTL.fn_code)) + (MATCH: regs_match_approx ge (analyze f)!!pc rs) + (STACKS: list_forall2 match_stackframes s s'), + match_states (State s c sp pc rs m) + (State s' (transf_code (analyze f) c) sp pc rs m) + | match_states_call: + forall s f args m s', + list_forall2 match_stackframes s s' -> + match_states (Callstate s f args m) + (Callstate s' (transf_fundef f) args m) + | match_states_return: + forall s s' v m, + list_forall2 match_stackframes s s' -> + match_states (Returnstate s v m) + (Returnstate s' v m). + +Ltac TransfInstr := + match goal with + | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => + cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr)); + [ simpl + | unfold transf_code; rewrite PTree.gmap; + unfold option_map; rewrite H1; reflexivity ] + end. + +(** The proof of simulation proceeds by case analysis on the transition + taken in the source code. *) + +Lemma 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. + + (* Inop *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + TransfInstr; intro. eapply exec_Inop; eauto. + econstructor; eauto. + eapply analyze_correct_1 with (pc := pc); eauto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. auto. + + (* Iop *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. + TransfInstr. caseEq (op_strength_reduction (analyze f)!!pc op args); + intros op' args' OSR. + assert (eval_operation tge sp op' rs##args' m = Some v). + rewrite (eval_operation_preserved symbols_preserved). + generalize (op_strength_reduction_correct ge (analyze f)!!pc sp rs + MATCH op args m v). + rewrite OSR; simpl. auto. + generalize (eval_static_operation_correct ge op sp + (approx_regs args (analyze f)!!pc) rs##args m v + (approx_regs_val_list _ _ _ args MATCH) H0). + case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; + simpl in H2; + eapply exec_Iop; eauto; simpl. + congruence. + congruence. + elim H2; intros b [A B]. rewrite symbols_preserved. + rewrite A; rewrite B; auto. + econstructor; eauto. + eapply analyze_correct_1 with (pc := pc); eauto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. + eapply eval_static_operation_correct; eauto. + apply approx_regs_val_list; auto. + + (* Iload *) + caseEq (addr_strength_reduction (analyze f)!!pc addr args); + intros addr' args' ASR. + assert (eval_addressing tge sp addr' rs##args' = Some a). + rewrite (eval_addressing_preserved symbols_preserved). + generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + eapply exec_Iload; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl; auto. + + (* Istore *) + caseEq (addr_strength_reduction (analyze f)!!pc addr args); + intros addr' args' ASR. + assert (eval_addressing tge sp addr' rs##args' = Some a). + rewrite (eval_addressing_preserved symbols_preserved). + generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + eapply exec_Istore; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. auto. + + (* Icall *) + exploit transf_ros_correct; eauto. intro FIND'. + TransfInstr; intro. + econstructor; split. + eapply exec_Icall; eauto. apply sig_function_translated; auto. + constructor; auto. constructor; auto. + econstructor; eauto. + intros. apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl. auto. + + (* Itailcall *) + exploit transf_ros_correct; eauto. intros FIND'. + TransfInstr; intro. + econstructor; split. + eapply exec_Itailcall; eauto. apply sig_function_translated; auto. + constructor; auto. + + (* Ialloc *) + TransfInstr; intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- (Vptr b Int.zero)) m'); split. + eapply exec_Ialloc; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl; auto. + + (* Icond, true *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp ifso rs m); split. + caseEq (cond_strength_reduction (analyze f)!!pc cond args); + intros cond' args' CSR. + assert (eval_condition cond' rs##args' m = Some true). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + generalize (eval_static_condition_correct ge cond _ _ m _ + (approx_regs_val_list _ _ _ args MATCH) ESC); intro. + replace b with true. intro; eapply exec_Inop; eauto. congruence. + intros. eapply exec_Icond_true; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Icond, false *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp ifnot rs m); split. + caseEq (cond_strength_reduction (analyze f)!!pc cond args); + intros cond' args' CSR. + assert (eval_condition cond' rs##args' m = Some false). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + generalize (eval_static_condition_correct ge cond _ _ m _ + (approx_regs_val_list _ _ _ args MATCH) ESC); intro. + replace b with false. intro; eapply exec_Inop; eauto. congruence. + intros. eapply exec_Icond_false; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Ireturn *) + exists (Returnstate s' (regmap_optget or Vundef rs) (free m stk)); split. + eapply exec_Ireturn; eauto. TransfInstr; auto. + constructor; auto. + + (* internal function *) + simpl. unfold transf_function. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. + apply analyze_correct_3; auto. + + (* external function *) + simpl. econstructor; split. + eapply exec_function_external; eauto. + constructor; auto. + + (* return *) + inv H3. inv H1. + econstructor; split. + eapply exec_return; eauto. + econstructor; eauto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. intro FIND. + exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. + econstructor; eauto. + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + reflexivity. + rewrite <- H2. apply sig_function_translated. + replace (Genv.init_mem tprog) with (Genv.init_mem prog). + constructor. constructor. auto. + symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. +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 H4. constructor. +Qed. + +(** The preservation of the observable behavior of the program then + follows, using the generic preservation theorem + [Smallstep.simulation_step_preservation]. *) + +Theorem transf_program_correct: + forall (beh: program_behavior), + exec_program prog beh -> exec_program tprog beh. +Proof. + unfold exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_step_correct. +Qed. + +End PRESERVATION. diff --git a/arm/Machregs.v b/arm/Machregs.v new file mode 100644 index 0000000..3466c0b --- /dev/null +++ b/arm/Machregs.v @@ -0,0 +1,80 @@ +(* *********************************************************************) +(* *) +(* 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 Coqlib. +Require Import Maps. +Require Import AST. + +(** ** 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]). +- Two integer registers, not allocatable, reserved as temporaries for + spilling and reloading ([ITx]). +- Two float registers, not allocatable, reserved as temporaries for + spilling and reloading ([FTx]). + + The type [mreg] does not include special-purpose machine registers + such as the stack pointer and the condition codes. *) + +Inductive mreg: Set := + (** Allocatable integer regs *) + | R0: mreg | R1: mreg | R2: mreg | R3: mreg + | R4: mreg | R5: mreg | R6: mreg | R7: mreg + | R8: mreg | R9: mreg | R11: mreg + (** Allocatable float regs *) + | F0: mreg | F1: mreg | F4: mreg | F5: mreg + | F6: mreg | F7: mreg + (** Integer temporaries *) + | IT1: mreg (* R10 *) | IT2: mreg (* R12 *) + (** Float temporaries *) + | FT1: mreg (* F2 *) | FT2: mreg (* F3 *). + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Qed. + +Definition mreg_type (r: mreg): typ := + match r with + | R0 => Tint | R1 => Tint | R2 => Tint | R3 => Tint + | R4 => Tint | R5 => Tint | R6 => Tint | R7 => Tint + | R8 => Tint | R9 => Tint | R11 => Tint + | F0 => Tfloat | F1 => Tfloat | F4 => Tfloat | F5 => Tfloat + | F6 => Tfloat | F7 => Tfloat + | IT1 => Tint | IT2 => Tint + | FT1 => Tfloat | FT2 => Tfloat + end. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + 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 + | R8 => 9 | R9 => 10 | R11 => 11 + | F0 => 12 | F1 => 13 | F4 => 14 | F5 => 15 + | F6 => 16 | F7 => 17 + | IT1 => 18 | IT2 => 19 + | FT1 => 20 | FT2 => 21 + end. + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + destruct r1; destruct r2; simpl; intro; discriminate || reflexivity. + Qed. +End IndexedMreg. + diff --git a/arm/Op.v b/arm/Op.v new file mode 100644 index 0000000..6a6df7e --- /dev/null +++ b/arm/Op.v @@ -0,0 +1,1007 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + semantics for the CminorSel, RTL, LTL and Mach languages depend on the + following types, defined in this library: +- [condition]: boolean conditions for conditional branches; +- [operation]: arithmetic and logical operations; +- [addressing]: addressing modes for load and store operations. + + These types are 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 Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. + +Set Implicit Arguments. + +Record shift_amount : Set := + mk_shift_amount { + s_amount: int; + s_amount_ltu: Int.ltu s_amount (Int.repr 32) = true + }. + +Inductive shift : Set := + | Slsl: shift_amount -> shift + | Slsr: shift_amount -> shift + | Sasr: shift_amount -> shift + | Sror: shift_amount -> shift. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Set := + | Ccomp: comparison -> condition (**r signed integer comparison *) + | Ccompu: comparison -> condition (**r unsigned integer comparison *) + | Ccompshift: comparison -> shift -> condition (**r signed integer comparison *) + | Ccompushift: comparison -> shift -> condition (**r unsigned integer comparison *) + | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) + | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) + | Ccompf: comparison -> condition (**r floating-point comparison *) + | Cnotcompf: comparison -> condition. (**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 : Set := + | Omove: operation (**r [rd = r1] *) + | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) + | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *) + | Oaddrsymbol: ident -> int -> operation (**r [rd] is set to the the address of the symbol plus the offset *) + | Oaddrstack: int -> operation (**r [rd] is set to the stack pointer plus the given offset *) +(*c Integer arithmetic: *) + | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) + | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) + | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) + | Oadd: operation (**r [rd = r1 + r2] *) + | Oaddshift: shift -> operation (**r [rd = r1 + shifted r2] *) + | Oaddimm: int -> operation (**r [rd = r1 + n] *) + | Osub: operation (**r [rd = r1 - r2] *) + | Osubshift: shift -> operation (**r [rd = r1 - shifted r2] *) + | Orsubshift: shift -> operation (**r [rd = shifted r2 - r1] *) + | Orsubimm: int -> operation (**r [rd = r1 - n] *) + | Omul: operation (**r [rd = r1 * r2] *) + | Odiv: operation (**r [rd = r1 / r2] (signed) *) + | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) + | Oand: operation (**r [rd = r1 & r2] *) + | Oandshift: shift -> operation (**r [rd = r1 & shifted r2] *) + | Oandimm: int -> operation (**r [rd = r1 & n] *) + | Oor: operation (**r [rd = r1 | r2] *) + | Oorshift: shift -> operation (**r [rd = r1 | shifted r2] *) + | Oorimm: int -> operation (**r [rd = r1 | n] *) + | Oxor: operation (**r [rd = r1 ^ r2] *) + | Oxorshift: shift -> operation (**r [rd = r1 ^ shifted r2] *) + | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) + | Obic: operation (**r [rd = r1 & ~r2] *) + | Obicshift: shift -> operation (**r [rd = r1 & ~(shifted r2)] *) + | Onot: operation (**r [rd = ~r1] *) + | Onotshift: shift -> operation (**r [rd = ~(shifted r1)] *) + | Oshl: operation (**r [rd = r1 << r2] *) + | Oshr: operation (**r [rd = r1 >> r2] (signed) *) + | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) + | Oshift: shift -> operation (**r [rd = shifted r1] *) + | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) +(*c Floating-point arithmetic: *) + | Onegf: operation (**r [rd = - r1] *) + | Oabsf: operation (**r [rd = abs(r1)] *) + | Oaddf: operation (**r [rd = r1 + r2] *) + | Osubf: operation (**r [rd = r1 - r2] *) + | Omulf: operation (**r [rd = r1 * r2] *) + | Odivf: operation (**r [rd = r1 / r2] *) + | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat: operation (**r [rd = int_of_float(r1)] *) + | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *) + | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *) + | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Set := + | Aindexed: int -> addressing (**r Address is [r1 + offset] *) + | Aindexed2: addressing (**r Address is [r1 + r2] *) + | Aindexed2shift: shift -> addressing (**r Address is [r1 + shifted r2] *) + | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in module [CSE]). *) + +Definition eq_shift (x y: shift): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + assert (forall (x y: shift_amount), {x=y}+{x<>y}). + destruct x as [x Px]. destruct y as [y Py]. destruct (H x y). + subst x. rewrite (proof_irrelevance _ Px Py). left; auto. + right. red; intro. elim n. inversion H0. auto. + decide equality. +Qed. + +Definition eq_operation (x y: operation): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + generalize Float.eq_dec; intro. + assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + generalize eq_shift; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + assert (forall (x y: condition), {x=y}+{x<>y}). decide equality. + decide equality. +Qed. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + generalize eq_shift; intro. + decide equality. +Qed. + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation is undefined: + wrong number of arguments, arguments of the wrong types, undefined + operations such as division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_compare_mismatch (c: comparison) : option bool := + match c with Ceq => Some false | Cne => Some true | _ => None end. + +Definition eval_compare_null (c: comparison) (n: int) : option bool := + if Int.eq n Int.zero + then match c with Ceq => Some false | Cne => Some true | _ => None end + else None. + +Definition eval_shift (s: shift) (n: int) : int := + match s with + | Slsl x => Int.shl n (s_amount x) + | Slsr x => Int.shru n (s_amount x) + | Sasr x => Int.shr n (s_amount x) + | Sror x => Int.ror n (s_amount x) + end. + +Definition eval_condition (cond: condition) (vl: list val) (m: mem): + option bool := + match cond, vl with + | Ccomp c, Vint n1 :: Vint n2 :: nil => + Some (Int.cmp c n1 n2) + | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => + if valid_pointer m b1 (Int.signed n1) + && valid_pointer m b2 (Int.signed n2) then + if eq_block b1 b2 + then Some (Int.cmp c n1 n2) + else eval_compare_mismatch c + else None + | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c n2 + | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => + eval_compare_null c n1 + | Ccompu c, Vint n1 :: Vint n2 :: nil => + Some (Int.cmpu c n1 n2) + | Ccompshift c s, Vint n1 :: Vint n2 :: nil => + Some (Int.cmp c n1 (eval_shift s n2)) + | Ccompshift c s, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c (eval_shift s n2) + | Ccompushift c s, Vint n1 :: Vint n2 :: nil => + Some (Int.cmpu c n1 (eval_shift s n2)) + | Ccompimm c n, Vint n1 :: nil => + Some (Int.cmp c n1 n) + | Ccompimm c n, Vptr b1 n1 :: nil => + eval_compare_null c n + | Ccompuimm c n, Vint n1 :: nil => + Some (Int.cmpu c n1 n) + | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (Float.cmp c f1 f2) + | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (negb (Float.cmp c f1 f2)) + | _, _ => + None + end. + +Definition offset_sp (sp: val) (delta: int) : option val := + match sp with + | Vptr b n => Some (Vptr b (Int.add n delta)) + | _ => None + end. + +Definition eval_operation + (F: Set) (genv: Genv.t F) (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) + | Ofloatconst n, nil => Some (Vfloat n) + | Oaddrsymbol s ofs, nil => + match Genv.find_symbol genv s with + | None => None + | Some b => Some (Vptr b ofs) + end + | Oaddrstack ofs, nil => offset_sp sp ofs + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) + | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) + | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) + | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) + | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) + | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) + | Oaddshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 (eval_shift s n2))) + | Oaddshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 (eval_shift s n2))) + | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) + | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) + | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) + | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) + | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => + if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None + | Osubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 (eval_shift s n2))) + | Osubshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 (eval_shift s n2))) + | Orsubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub (eval_shift s n2) n1)) + | Orsubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) + | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) + | Odiv, Vint n1 :: Vint n2 :: nil => + if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) + | Odivu, Vint n1 :: Vint n2 :: nil => + if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) + | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) + | Oandshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (eval_shift s n2))) + | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) + | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) + | Oorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 (eval_shift s n2))) + | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) + | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) + | Oxorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 (eval_shift s n2))) + | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) + | Obic, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not n2))) + | Obicshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not (eval_shift s n2)))) + | Onot, Vint n1 :: nil => Some (Vint (Int.not n1)) + | Onotshift s, Vint n1 :: nil => Some (Vint (Int.not (eval_shift s n1))) + | Oshl, Vint n1 :: Vint n2 :: nil => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shl n1 n2)) else None + | Oshr, Vint n1 :: Vint n2 :: nil => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None + | Oshru, Vint n1 :: Vint n2 :: nil => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None + | Oshift s, Vint n :: nil => Some (Vint (eval_shift s n)) + | Oshrximm n, Vint n1 :: nil => + if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) else None + | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) + | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) + | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) + | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) + | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) + | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) + | Osingleoffloat, v1 :: nil => + Some (Val.singleoffloat v1) + | Ointoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intoffloat f1)) + | Ointuoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intuoffloat f1)) + | Ofloatofint, Vint n1 :: nil => + Some (Vfloat (Float.floatofint n1)) + | Ofloatofintu, Vint n1 :: nil => + Some (Vfloat (Float.floatofintu n1)) + | Ocmp c, _ => + match eval_condition c vl m with + | None => None + | Some false => Some Vfalse + | Some true => Some Vtrue + end + | _, _ => None + end. + +Definition eval_addressing + (F: Set) (genv: Genv.t F) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, Vptr b1 n1 :: nil => + Some (Vptr b1 (Int.add n1 n)) + | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => + Some (Vptr b1 (Int.add n1 n2)) + | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => + Some (Vptr b2 (Int.add n1 n2)) + | Aindexed2shift s, Vptr b1 n1 :: Vint n2 :: nil => + Some (Vptr b1 (Int.add n1 (eval_shift s n2))) + | Ainstack ofs, nil => + offset_sp sp ofs + | _, _ => None + end. + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompshift c s => Ccompshift (negate_comparison c) s + | Ccompushift c s => Ccompushift (negate_comparison c) s + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + end. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; try discriminate; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; try discriminate; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | _ => + idtac + end. + +Remark eval_negate_compare_null: + forall c n b, + eval_compare_null c n = Some b -> + eval_compare_null (negate_comparison c) n = Some (negb b). +Proof. + intros until b. unfold eval_compare_null. + case (Int.eq n Int.zero). + destruct c; intro EQ; simplify_eq EQ; intros; subst b; reflexivity. + intro; discriminate. +Qed. + +Lemma eval_negate_condition: + forall (cond: condition) (vl: list val) (b: bool) (m: mem), + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). +Proof. + intros. + destruct cond; simpl in H; FuncInv; try subst b; simpl. + rewrite Int.negate_cmp. auto. + apply eval_negate_compare_null; auto. + apply eval_negate_compare_null; auto. + destruct (valid_pointer m b0 (Int.signed i) && + valid_pointer m b1 (Int.signed i0)). + destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. + destruct c; simpl in H; inv H; auto. + discriminate. + rewrite Int.negate_cmpu. auto. + rewrite Int.negate_cmp. auto. + apply eval_negate_compare_null; auto. + rewrite Int.negate_cmpu. auto. + rewrite Int.negate_cmp. auto. + apply eval_negate_compare_null; auto. + rewrite Int.negate_cmpu. auto. + auto. + rewrite negb_elim. auto. +Qed. + +(** [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: Set. +Variable ge1: Genv.t F1. +Variable ge2: Genv.t F2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +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; try rewrite agree_on_symbols; + reflexivity. +Qed. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + assert (UNUSED: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s). + exact agree_on_symbols. + unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; + reflexivity. +Qed. + +End GENV_TRANSF. + +(** [eval_condition] and [eval_operation] depend on a memory store + (to check pointer validity in pointer comparisons). + We show that their results are preserved by a change of + memory if this change preserves pointer validity. + In particular, this holds in case of a memory allocation + or a memory store. *) + +Lemma eval_condition_change_mem: + forall m m' c args b, + (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> + eval_condition c args m = Some b -> eval_condition c args m' = Some b. +Proof. + intros until b. intro INV. destruct c; simpl; auto. + destruct args; auto. destruct v; auto. destruct args; auto. + destruct v; auto. destruct args; auto. + caseEq (valid_pointer m b0 (Int.signed i)); intro. + caseEq (valid_pointer m b1 (Int.signed i0)); intro. + simpl. rewrite (INV _ _ H). rewrite (INV _ _ H0). auto. + simpl; congruence. simpl; congruence. +Qed. + +Lemma eval_operation_change_mem: + forall (F: Set) m m' (ge: Genv.t F) sp op args v, + (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros until v; intro INV. destruct op; simpl; auto. + caseEq (eval_condition c args m); intros. + rewrite (eval_condition_change_mem _ _ _ _ INV H). auto. + discriminate. +Qed. + +Lemma eval_condition_alloc: + forall m lo hi m' b c args v, + Mem.alloc m lo hi = (m', b) -> + eval_condition c args m = Some v -> eval_condition c args m' = Some v. +Proof. + intros. apply eval_condition_change_mem with m; auto. + intros. eapply valid_pointer_alloc; eauto. +Qed. + +Lemma eval_operation_alloc: + forall (F: Set) m lo hi m' b (ge: Genv.t F) sp op args v, + Mem.alloc m lo hi = (m', b) -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros. apply eval_operation_change_mem with m; auto. + intros. eapply valid_pointer_alloc; eauto. +Qed. + +Lemma eval_condition_store: + forall chunk m b ofs v' m' c args v, + Mem.store chunk m b ofs v' = Some m' -> + eval_condition c args m = Some v -> eval_condition c args m' = Some v. +Proof. + intros. apply eval_condition_change_mem with m; auto. + intros. eapply valid_pointer_store; eauto. +Qed. + +Lemma eval_operation_store: + forall (F: Set) chunk m b ofs v' m' (ge: Genv.t F) sp op args v, + Mem.store chunk m b ofs v' = Some m' -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros. apply eval_operation_change_mem with m; auto. + intros. eapply valid_pointer_store; eauto. +Qed. + +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Set) (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: Set) (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. + +(** 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 + | Ccompshift _ _ => Tint :: Tint :: nil + | Ccompushift _ _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Ofloatconst _ => (nil, Tfloat) + | Oaddrsymbol _ _ => (nil, Tint) + | Oaddrstack _ => (nil, Tint) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast8unsigned => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Ocast16unsigned => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddshift _ => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Osubshift _ => (Tint :: Tint :: nil, Tint) + | Orsubshift _ => (Tint :: Tint :: nil, Tint) + | Orsubimm _ => (Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandshift _ => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorshift _ => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorshift _ => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Obic => (Tint :: Tint :: nil, Tint) + | Obicshift _ => (Tint :: Tint :: nil, Tint) + | Onot => (Tint :: nil, Tint) + | Onotshift _ => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshift _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | 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) + | Osingleoffloat => (Tfloat :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ocmp c => (type_of_condition c, Tint) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tint :: nil + | Aindexed2 => Tint :: Tint :: nil + | Aindexed2shift _ => Tint :: Tint :: nil + | Ainstack _ => nil + end. + +Definition type_of_chunk (c: memory_chunk) : typ := + match c with + | Mint8signed => Tint + | Mint8unsigned => Tint + | Mint16signed => Tint + | Mint16unsigned => Tint + | Mint32 => Tint + | Mfloat32 => Tfloat + | Mfloat64 => Tfloat + 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: Set. +Variable genv: Genv.t A. + +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. + intros. + destruct op; simpl in H0; FuncInv; try subst v; try exact I. + congruence. + destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I. + simpl. unfold offset_sp in H0. destruct sp; try discriminate. + inversion H0. exact I. + destruct v0; exact I. + destruct v0; exact I. + destruct v0; exact I. + destruct v0; exact I. + destruct (eq_block b b0). injection H0; intro; subst v; exact I. + discriminate. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i (Int.repr 31)). + injection H0; intro; subst v; exact I. discriminate. + destruct v0; exact I. + destruct (eval_condition c vl). + destruct b; injection H0; intro; subst v; exact I. + discriminate. +Qed. + +Lemma type_of_chunk_correct: + forall chunk m addr v, + Mem.loadv chunk m addr = Some v -> + Val.has_type v (type_of_chunk chunk). +Proof. + intro chunk. + assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)). + destruct v; destruct chunk; exact I. + intros until v. unfold Mem.loadv. + destruct addr; intros; try discriminate. + generalize (Mem.load_inv _ _ _ _ _ H0). + intros [X Y]. subst v. apply H. +Qed. + +End SOUNDNESS. + +(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] + as total functions that return [Vundef] when not applicable + (instead of [None]). Used in the proof of [PPCgen]. *) + +Section EVAL_OP_TOTAL. + +Variable F: Set. +Variable genv: Genv.t F. + +Definition find_symbol_offset (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. + +Definition eval_shift_total (s: shift) (v: val) : val := + match v with + | Vint n => Vint(eval_shift s n) + | _ => Vundef + end. + +Definition eval_condition_total (cond: condition) (vl: list val) : val := + match cond, vl with + | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 + | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 + | Ccompshift c s, v1::v2::nil => Val.cmp c v1 (eval_shift_total s v2) + | Ccompushift c s, v1::v2::nil => Val.cmpu c v1 (eval_shift_total s v2) + | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) + | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) + | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 + | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) + | _, _ => Vundef + end. + +Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => Vint n + | Ofloatconst n, nil => Vfloat n + | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs + | Oaddrstack ofs, nil => Val.add sp (Vint ofs) + | Ocast8signed, v1::nil => Val.sign_ext 8 v1 + | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 + | Ocast16signed, v1::nil => Val.sign_ext 16 v1 + | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 + | Oadd, v1::v2::nil => Val.add v1 v2 + | Oaddshift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) + | Oaddimm n, v1::nil => Val.add v1 (Vint n) + | Osub, v1::v2::nil => Val.sub v1 v2 + | Osubshift s, v1::v2::nil => Val.sub v1 (eval_shift_total s v2) + | Orsubshift s, v1::v2::nil => Val.sub (eval_shift_total s v2) v1 + | Orsubimm n, v1::nil => Val.sub (Vint n) v1 + | Omul, v1::v2::nil => Val.mul v1 v2 + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Oand, v1::v2::nil => Val.and v1 v2 + | Oandshift s, v1::v2::nil => Val.and v1 (eval_shift_total s v2) + | Oandimm n, v1::nil => Val.and v1 (Vint n) + | Oor, v1::v2::nil => Val.or v1 v2 + | Oorshift s, v1::v2::nil => Val.or v1 (eval_shift_total s v2) + | Oorimm n, v1::nil => Val.or v1 (Vint n) + | Oxor, v1::v2::nil => Val.xor v1 v2 + | Oxorshift s, v1::v2::nil => Val.xor v1 (eval_shift_total s v2) + | Oxorimm n, v1::nil => Val.xor v1 (Vint n) + | Obic, v1::v2::nil => Val.and v1 (Val.notint v2) + | Obicshift s, v1::v2::nil => Val.and v1 (Val.notint (eval_shift_total s v2)) + | Onot, v1::nil => Val.notint v1 + | Onotshift s, v1::nil => Val.notint (eval_shift_total s v1) + | Oshl, v1::v2::nil => Val.shl v1 v2 + | Oshr, v1::v2::nil => Val.shr v1 v2 + | Oshru, v1::v2::nil => Val.shru v1 v2 + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshift s, v1::nil => eval_shift_total s v1 + | Onegf, v1::nil => Val.negf v1 + | Oabsf, v1::nil => Val.absf v1 + | Oaddf, v1::v2::nil => Val.addf v1 v2 + | Osubf, v1::v2::nil => Val.subf v1 v2 + | Omulf, v1::v2::nil => Val.mulf v1 v2 + | Odivf, v1::v2::nil => Val.divf v1 v2 + | Osingleoffloat, v1::nil => Val.singleoffloat 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 + | Ocmp c, _ => eval_condition_total c vl + | _, _ => Vundef + end. + +Definition eval_addressing_total + (sp: val) (addr: addressing) (vl: list val) : val := + match addr, vl with + | Aindexed n, v1::nil => Val.add v1 (Vint n) + | Aindexed2, v1::v2::nil => Val.add v1 v2 + | Aindexed2shift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) + | Ainstack ofs, nil => Val.add sp (Vint ofs) + | _, _ => Vundef + end. + +Lemma eval_compare_mismatch_weaken: + forall c b, + eval_compare_mismatch c = Some b -> + Val.cmp_mismatch c = Val.of_bool b. +Proof. + unfold eval_compare_mismatch. intros. destruct c; inv H; auto. +Qed. + +Lemma eval_compare_null_weaken: + forall c i b, + eval_compare_null c i = Some b -> + (if Int.eq i Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. +Proof. + unfold eval_compare_null. intros. + destruct (Int.eq i Int.zero); try discriminate. + apply eval_compare_mismatch_weaken; auto. +Qed. + +Lemma eval_condition_weaken: + forall c vl m b, + eval_condition c vl m = Some b -> + eval_condition_total c vl = Val.of_bool b. +Proof. + intros. + unfold eval_condition in H; destruct c; FuncInv; + try subst b; try reflexivity; simpl; + try (apply eval_compare_null_weaken; auto). + destruct (valid_pointer m b0 (Int.signed i) && + valid_pointer m b1 (Int.signed i0)). + unfold eq_block in H. destruct (zeq b0 b1); try congruence. + apply eval_compare_mismatch_weaken; auto. + discriminate. + symmetry. apply Val.notbool_negb_1. +Qed. + +Lemma eval_operation_weaken: + forall sp op vl m v, + eval_operation genv sp op vl m = Some v -> + eval_operation_total sp op vl = v. +Proof. + intros. + unfold eval_operation in H; destruct op; FuncInv; + try subst v; try reflexivity; simpl. + unfold find_symbol_offset. + destruct (Genv.find_symbol genv i); try discriminate. + congruence. + unfold offset_sp in H. + destruct sp; try discriminate. simpl. congruence. + unfold eq_block in H. destruct (zeq b b0); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + unfold Int.ltu in H. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))). + unfold Int.ltu. rewrite zlt_true. congruence. + assert (Int.unsigned (Int.repr 31) < Int.unsigned (Int.repr 32)). vm_compute; auto. + omega. discriminate. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. + replace v with (Val.of_bool b). + eapply eval_condition_weaken; eauto. + destruct b; simpl; congruence. + discriminate. +Qed. + +Lemma eval_addressing_weaken: + forall sp addr vl v, + eval_addressing genv sp addr vl = Some v -> + eval_addressing_total sp addr vl = v. +Proof. + intros. + unfold eval_addressing in H; destruct addr; FuncInv; + try subst v; simpl; try reflexivity. + decEq. apply Int.add_commut. + unfold offset_sp in H. destruct sp; simpl; congruence. +Qed. + +Lemma eval_condition_total_is_bool: + forall cond vl, Val.is_bool (eval_condition_total cond vl). +Proof. + intros; destruct cond; + destruct vl; try apply Val.undef_is_bool; + destruct vl; try apply Val.undef_is_bool; + try (destruct vl; try apply Val.undef_is_bool); simpl. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmpf_is_bool. + apply Val.notbool_is_bool. +Qed. + +End EVAL_OP_TOTAL. + +(** Compatibility of the evaluation functions with the + ``is less defined'' relation over values and memory states. *) + +Section EVAL_LESSDEF. + +Variable F: Set. +Variable genv: Genv.t F. +Variables m1 m2: mem. +Hypothesis MEM: Mem.lessdef m1 m2. + +Ltac InvLessdef := + match goal with + | [ H: Val.lessdef (Vint _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef (Vfloat _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef_list nil _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => + inv H; InvLessdef + | _ => idtac + end. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b, + Val.lessdef_list vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. + generalize H0. + caseEq (valid_pointer m1 b0 (Int.signed i)); intro; simpl; try congruence. + caseEq (valid_pointer m1 b1 (Int.signed i0)); intro; simpl; try congruence. + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl. auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => + exists v1; split; [auto | constructor] + | _ => idtac + end. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + 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. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. + exists v2; auto. + destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + exists v1; auto. + exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. + exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. + destruct (eq_block b b0); inv H0. TrivialExists. + destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H1; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H1; TrivialExists. + destruct (Int.ltu i (Int.repr 31)); inv H0; TrivialExists. + exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. + caseEq (eval_condition c vl1 m1); intros. rewrite H1 in H0. + rewrite (eval_condition_lessdef c H H1). + destruct b; inv H0; TrivialExists. + rewrite H1 in H0. discriminate. +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. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. + exists v1; auto. +Qed. + +End EVAL_LESSDEF. + +(** Recognition of integers that are valid shift amounts. *) + +Definition is_shift_amount_aux (n: int) : + { Int.ltu n (Int.repr 32) = true } + + { Int.ltu n (Int.repr 32) = false }. +Proof. + intro. case (Int.ltu n (Int.repr 32)). left; auto. right; auto. +Defined. + +Definition is_shift_amount (n: int) : option shift_amount := + match is_shift_amount_aux n with + | left H => Some(mk_shift_amount n H) + | right _ => None + end. + +Lemma is_shift_amount_Some: + forall n s, is_shift_amount n = Some s -> s_amount s = n. +Proof. + intros until s. unfold is_shift_amount. + destruct (is_shift_amount_aux n). + simpl. intros. inv H. reflexivity. + congruence. +Qed. + +Lemma is_shift_amount_None: + forall n, is_shift_amount n = None -> Int.ltu n (Int.repr 32) = true -> False. +Proof. + intro n. unfold is_shift_amount. + destruct (is_shift_amount_aux n). + congruence. + congruence. +Qed. + +(** Transformation of addressing modes with two operands or more + into an equivalent arithmetic operation. This is used in the [Reload] + pass when a store instruction cannot be reloaded directly because + it runs out of temporary registers. *) + +(** For the ARM, there are only two binary addressing mode: [Aindexed2] + and [Aindexed2shift]. The corresponding operations are [Oadd] + and [Oaddshift]. *) + +Definition op_for_binary_addressing (addr: addressing) : operation := + match addr with + | Aindexed2 => Oadd + | Aindexed2shift s => Oaddshift s + | _ => Ointconst Int.zero (* never happens *) + end. + +Lemma eval_op_for_binary_addressing: + forall (F: Set) (ge: Genv.t F) sp addr args m v, + (length args >= 2)%nat -> + eval_addressing ge sp addr args = Some v -> + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. +Proof. + intros. + unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; simpl. + rewrite Int.add_commut. congruence. + congruence. + congruence. +Qed. + +Lemma type_op_for_binary_addressing: + forall addr, + (length (type_of_addressing addr) >= 2)%nat -> + type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). +Proof. + intros. destruct addr; simpl in H; reflexivity || omegaContradiction. +Qed. diff --git a/arm/Selection.v b/arm/Selection.v new file mode 100644 index 0000000..d5eb6b8 --- /dev/null +++ b/arm/Selection.v @@ -0,0 +1,1394 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Instruction selection *) + +(** 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. + + Instruction selection proceeds by bottom-up rewriting over expressions. + The source language is Cminor and the target language is CminorSel. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Cminor. +Require Import Op. +Require Import CminorSel. + +Infix ":::" := Econs (at level 60, right associativity) : selection_scope. + +Open Local Scope selection_scope. + +(** * Lifting of let-bound variables *) + +(** Some of the instruction functions generate [Elet] constructs to + share the evaluation of a subexpression. Owing to the use of de + Bruijn indices for let-bound variables, we need to shift de Bruijn + indices when an expression [b] is put in a [Elet a b] context. *) + +Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr := + match a with + | Evar id => Evar id + | Eop op bl => Eop op (lift_exprlist p bl) + | Eload chunk addr bl => Eload chunk addr (lift_exprlist p bl) + | Econdition b c d => + Econdition (lift_condexpr p b) (lift_expr p c) (lift_expr p d) + | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c) + | Eletvar n => + if le_gt_dec p n then Eletvar (S n) else Eletvar n + end + +with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := + match a with + | CEtrue => CEtrue + | CEfalse => CEfalse + | CEcond cond bl => CEcond cond (lift_exprlist p bl) + | CEcondition b c d => + CEcondition (lift_condexpr p b) (lift_condexpr p c) (lift_condexpr p d) + end + +with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist := + match a with + | Enil => Enil + | Econs b cl => Econs (lift_expr p b) (lift_exprlist p cl) + end. + +Definition lift (a: expr): expr := lift_expr O a. + +(** * Smart constructors for operators *) + +(** This section 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. +*) + +(** ** Integer logical negation *) + +(** The natural way to write smart constructors is by pattern-matching + on their arguments, recognizing cases where cheaper operators + or combined operators are applicable. For instance, integer logical + negation has three special cases (not-and, not-or and not-xor), + along with a default case that uses not-or over its arguments and itself. + This is written naively as follows: +<< +Definition notint (e: expr) := + match e with + | Eop (Oshift s) (t1:::Enil) => Eop (Onotshift s) (t1:::Enil) + | Eop Onot (t1:::Enil) => t1 + | Eop (Onotshift s) (t1:::Enil) => Eop (Oshift s) (t1:::Enil) + | _ => Eop Onot (e:::Enil) + end. +>> + However, Coq expands complex pattern-matchings like the above into + elementary matchings over all constructors of an inductive type, + resulting in much duplication of the final catch-all case. + Such duplications generate huge executable code and duplicate + cases in the correctness proofs. + + To limit this duplication, we use the following trick due to + Yves Bertot. We first define a dependent inductive type that + characterizes the expressions that match each of the 4 cases of interest. +*) + +Inductive notint_cases: forall (e: expr), Set := + | notint_case1: + forall s t1, + notint_cases (Eop (Oshift s) (t1:::Enil)) + | notint_case2: + forall t1, + notint_cases (Eop Onot (t1:::Enil)) + | notint_case3: + forall s t1, + notint_cases (Eop (Onotshift s) (t1:::Enil)) + | notint_default: + forall (e: expr), + notint_cases e. + +(** We then define a classification function that takes an expression + and return the case in which it falls. Note that the catch-all case + [notint_default] does not state that it is mutually exclusive with + the first three, more specific cases. The classification function + nonetheless chooses the specific cases in preference to the catch-all + case. *) + +Definition notint_match (e: expr) := + match e as z1 return notint_cases z1 with + | Eop (Oshift s) (t1:::Enil) => + notint_case1 s t1 + | Eop Onot (t1:::Enil) => + notint_case2 t1 + | Eop (Onotshift s) (t1:::Enil) => + notint_case3 s t1 + | e => + notint_default e + end. + +(** Finally, the [notint] function we need is defined by a 4-case match + over the result of the classification function. Thus, no duplication + of the right-hand sides of this match occur, and the proof has only + 4 cases to consider (it proceeds by case over [notint_match e]). + Since the default case is not obviously exclusive with the three + specific cases, it is important that its right-hand side is + semantically correct for all possible values of [e], which is the + case here and for all other smart constructors. *) + +Definition notint (e: expr) := + match notint_match e with + | notint_case1 s t1 => + Eop (Onotshift s) (t1:::Enil) + | notint_case2 t1 => + t1 + | notint_case3 s t1 => + Eop (Oshift s) (t1:::Enil) + | notint_default e => + Eop Onot (e:::Enil) + end. + +(** This programming pattern will be applied systematically for the + other smart constructors in this file. *) + +(** ** Boolean negation *) + +Definition notbool_base (e: expr) := + Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). + +Fixpoint notbool (e: expr) {struct e} : expr := + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp (negate_condition cond)) args + | Econdition e1 e2 e3 => + Econdition e1 (notbool e2) (notbool e3) + | _ => + notbool_base e + end. + +(** ** Integer addition and pointer addition *) + +(** Addition of an integer constant. *) + +(* +Definition 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 (Int.add n m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add 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), Set := + | 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 z1 return addimm_cases z1 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(Int.add n m)) Enil + | addimm_case2 s m => + Eop (Oaddrsymbol s (Int.add n m)) Enil + | addimm_case3 m => + Eop (Oaddrstack (Int.add n m)) Enil + | addimm_case4 m t => + Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | addimm_default e => + Eop (Oaddimm n) (e ::: Enil) + end. + +(** Addition of two integer or pointer expressions. *) + +(* +Definition add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | 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)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oaddshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oaddshift s) (t1:::t2:::Enil) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Set := + | add_case1: + forall n1 t2, + add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: + forall n1 t1 n2 t2, + add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case3: + forall n1 t1 t2, + add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | add_case4: + forall t1 n2, + add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case5: + forall t1 n2 t2, + add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case6: + forall s t1 t2, + add_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | add_case7: + forall t1 s t2, + add_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | add_default: + forall (e1: expr) (e2: expr), + add_cases e1 e2. + +Definition add_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return add_cases z1 z2 with + | Eop (Ointconst n1) Enil, t2 => + add_case1 n1 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + add_case2 n1 t1 n2 t2 + | Eop(Oaddimm n1) (t1:::Enil), t2 => + add_case3 n1 t1 t2 + | t1, Eop (Ointconst n2) Enil => + add_case4 t1 n2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => + add_case5 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + add_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + add_case7 t1 s t2 + | e1, e2 => + add_default e1 e2 + end. + +Definition add (e1: expr) (e2: expr) := + match add_match e1 e2 with + | add_case1 n1 t2 => + addimm n1 t2 + | add_case2 n1 t1 n2 t2 => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | add_case3 n1 t1 t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | add_case4 t1 n2 => + addimm n2 t1 + | add_case5 t1 n2 t2 => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | add_case6 s t1 t2 => + Eop (Oaddshift s) (t2:::t1:::Enil) + | add_case7 t1 s t2 => + Eop (Oaddshift s) (t1:::t2:::Enil) + | add_default e1 e2 => + Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +(* +Definition 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 (intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rnil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::::t2:::Enil)) + | Eop (Ointconst n1) Enil, t2 => Eop (Orsubimm n1) (t2:::Enil) + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Orsubshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Osubshift s) (t1:::t2:::Enil) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Set := + | 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_case5: + forall n1 t2, + sub_cases (Eop (Ointconst n1) Enil) (t2) + | sub_case6: + forall s t1 t2, + sub_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | sub_case7: + forall t1 s t2, + sub_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | sub_default: + forall (e1: expr) (e2: expr), + sub_cases e1 e2. + +Definition sub_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return sub_cases z1 z2 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 + | Eop (Ointconst n1) Enil, t2 => + sub_case5 n1 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + sub_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + sub_case7 t1 s t2 + | e1, e2 => + sub_default e1 e2 + end. + +Definition sub (e1: expr) (e2: expr) := + match sub_match e1 e2 with + | sub_case1 t1 n2 => + addimm (Int.neg n2) t1 + | sub_case2 n1 t1 n2 t2 => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | sub_case3 n1 t1 t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | sub_case4 t1 n2 t2 => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | sub_case5 n1 t2 => + Eop (Orsubimm n1) (t2:::Enil) + | sub_case6 s t1 t2 => + Eop (Orsubshift s) (t2:::t1:::Enil) + | sub_case7 t1 s t2 => + Eop (Osubshift s) (t1:::t2:::Enil) + | sub_default e1 e2 => + Eop Osub (e1:::e2:::Enil) + end. + +(** ** Immediate shifts *) + +(* +Definition shlimm (e1: expr) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) + | Eop (Oshift (Olsl n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Olsl (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsl n)) (e1:::Enil) + | _ => Eop (Oshift (Olsl n)) (e1:::Enil) + end. +*) + +Inductive shlimm_cases: forall (e1: expr), Set := + | shlimm_case1: + forall n1, + shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: + forall n1 t1, + shlimm_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) + | shlimm_default: + forall (e1: expr), + shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as z1 return shlimm_cases z1 with + | Eop (Ointconst n1) Enil => + shlimm_case1 n1 + | Eop (Oshift (Slsl 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 + match is_shift_amount n with + | None => Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shlimm_match e1 with + | shlimm_case1 n1 => + Eop (Ointconst(Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Slsl n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Slsl n'')) (t1:::Enil) + end + | shlimm_default e1 => + Eop (Oshift (Slsl n')) (e1:::Enil) + end + end. + +(* +Definition shruimm (e1: expr) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) + | Eop (Oshift (Olsr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Olsr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsr n)) (e1:::Enil) + | _ => Eop (Oshift (Olsr n)) (e1:::Enil) + end. +*) + +Inductive shruimm_cases: forall (e1: expr), Set := + | shruimm_case1: + forall n1, + shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: + forall n1 t1, + shruimm_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) + | shruimm_default: + forall (e1: expr), + shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as z1 return shruimm_cases z1 with + | Eop (Ointconst n1) Enil => + shruimm_case1 n1 + | Eop (Oshift (Slsr 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 + match is_shift_amount n with + | None => Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shruimm_match e1 with + | shruimm_case1 n1 => + Eop (Ointconst(Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Slsr n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Slsr n'')) (t1:::Enil) + end + | shruimm_default e1 => + Eop (Oshift (Slsr n')) (e1:::Enil) + end + end. + +(* +Definition shrimm (e1: expr) := + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) + | Eop (Oshift (Oasr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Oasr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Oasr n)) (e1:::Enil) + | _ => Eop (Oshift (Oasr n)) (e1:::Enil) + end. +*) + +Inductive shrimm_cases: forall (e1: expr), Set := + | shrimm_case1: + forall n1, + shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: + forall n1 t1, + shrimm_cases (Eop (Oshift (Sasr n1)) (t1:::Enil)) + | shrimm_default: + forall (e1: expr), + shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as z1 return shrimm_cases z1 with + | Eop (Ointconst n1) Enil => + shrimm_case1 n1 + | Eop (Oshift (Sasr 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 + match is_shift_amount n with + | None => Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shrimm_match e1 with + | shrimm_case1 n1 => + Eop (Ointconst(Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Sasr n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Sasr n'')) (t1:::Enil) + end + | shrimm_default e1 => + Eop (Oshift (Sasr n')) (e1:::Enil) + end + 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. + +(* +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 e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. +*) + +Inductive mulimm_cases: forall (e2: expr), Set := + | mulimm_case1: + forall (n2: int), + mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: + forall (n2: int) (t2: expr), + mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) + | mulimm_default: + forall (e2: expr), + mulimm_cases e2. + +Definition mulimm_match (e2: expr) := + match e2 as z1 return mulimm_cases z1 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(Int.mul n1 n2)) Enil + | mulimm_case2 n2 t2 => + addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | mulimm_default e2 => + mulimm_base n1 e2 + end. + +(* +Definition 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), Set := + | mul_case1: + forall (n1: int) (t2: expr), + mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: + forall (t1: expr) (n2: int), + mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: + forall (e1: expr) (e2: expr), + mul_cases e1 e2. + +Definition mul_match_aux (e1: expr) (e2: expr) := + match e2 as z2 return mul_cases e1 z2 with + | Eop (Ointconst n2) Enil => + mul_case2 e1 n2 + | e2 => + mul_default e1 e2 + end. + +Definition mul_match (e1: expr) (e2: expr) := + match e1 as z1 return mul_cases z1 e2 with + | Eop (Ointconst n1) Enil => + mul_case1 n1 e2 + | e1 => + mul_match_aux e1 e2 + end. + +Definition mul (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => + mulimm n1 t2 + | mul_case2 t1 n2 => + mulimm n2 t1 + | mul_default e1 e2 => + Eop Omul (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition mod_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Osub (Eletvar 1 ::: + Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil) ::: + Enil))). + +Inductive divu_cases: forall (e2: expr), Set := + | divu_case1: + forall (n2: int), + divu_cases (Eop (Ointconst n2) Enil) + | divu_default: + forall (e2: expr), + divu_cases e2. + +Definition divu_match (e2: expr) := + match e2 as z1 return divu_cases z1 with + | Eop (Ointconst n2) Enil => + divu_case1 n2 + | e2 => + divu_default e2 + end. + +Definition divu (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => shruimm e1 l2 + | None => Eop Odivu (e1:::e2:::Enil) + end + | divu_default e2 => + Eop Odivu (e1:::e2:::Enil) + end. + +Definition modu (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => Eop (Oandimm (Int.sub n2 Int.one)) (e1:::Enil) + | None => mod_aux Odivu e1 e2 + end + | divu_default e2 => + mod_aux Odivu e1 e2 + end. + +Definition divs (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => if Int.ltu l2 (Int.repr 31) + then Eop (Oshrximm l2) (e1:::Enil) + else Eop Odiv (e1:::e2:::Enil) + | None => Eop Odiv (e1:::e2:::Enil) + end + | divu_default e2 => + Eop Odiv (e1:::e2:::Enil) + end. + +Definition mods := mod_aux Odiv. (* could be improved *) + + +(** ** Bitwise and, or, xor *) + +(* +Definition and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oandshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oandshift s) (t1:::t2:::Enil) + | Eop (Onotshift s) (t1:::Enil), t2 => Eop (Obicshift s) (t2:::t1:::Enil) + | t1, Eop (Onotshift s) (t2:::Enil) => Eop (Obicshift s) (t1:::t2:::Enil) + | Eop Onot (t1:::Enil), t2 => Eop Obic (t2:::t1:::Enil) + | t1, Eop Onot (t2:::Enil) => Eop Obic (t1:::t2:::Enil) + | _, _ => Eop Oand (e1:::e2:::Enil) + end. +*) + +Inductive and_cases: forall (e1: expr) (e2: expr), Set := + | and_case1: + forall s t1 t2, + and_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | and_case2: + forall t1 s t2, + and_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | and_case3: + forall s t1 t2, + and_cases (Eop (Onotshift s) (t1:::Enil)) (t2) + | and_case4: + forall t1 s t2, + and_cases (t1) (Eop (Onotshift s) (t2:::Enil)) + | and_case5: + forall t1 t2, + and_cases (Eop Onot (t1:::Enil)) (t2) + | and_case6: + 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 z1, e2 as z2 return and_cases z1 z2 with + | Eop (Oshift s) (t1:::Enil), t2 => + and_case1 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + and_case2 t1 s t2 + | Eop (Onotshift s) (t1:::Enil), t2 => + and_case3 s t1 t2 + | t1, Eop (Onotshift s) (t2:::Enil) => + and_case4 t1 s t2 + | Eop Onot (t1:::Enil), t2 => + and_case5 t1 t2 + | t1, Eop Onot (t2:::Enil) => + and_case6 t1 t2 + | e1, e2 => + and_default e1 e2 + end. + +Definition and (e1: expr) (e2: expr) := + match and_match e1 e2 with + | and_case1 s t1 t2 => + Eop (Oandshift s) (t2:::t1:::Enil) + | and_case2 t1 s t2 => + Eop (Oandshift s) (t1:::t2:::Enil) + | and_case3 s t1 t2 => + Eop (Obicshift s) (t2:::t1:::Enil) + | and_case4 t1 s t2 => + Eop (Obicshift s) (t1:::t2:::Enil) + | and_case5 t1 t2 => + Eop Obic (t2:::t1:::Enil) + | and_case6 t1 t2 => + Eop Obic (t1:::t2:::Enil) + | and_default e1 e2 => + Eop Oand (e1:::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. + +(* +Definition or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift (Olsl n1) (t1:::Enil), Eop (Oshift (Olsr n2) (t2:::Enil)) => ... + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oorshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oorshift s) (t1:::t2:::Enil) + | _, _ => Eop Oor (e1:::e2:::Enil) + end. +*) + +(* TODO: symmetric of first case *) + +Inductive or_cases: forall (e1: expr) (e2: expr), Set := + | or_case1: + forall n1 t1 n2 t2, + or_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) (Eop (Oshift (Slsr n2)) (t2:::Enil)) + | or_case2: + forall s t1 t2, + or_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | or_case3: + forall t1 s t2, + or_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | or_default: + forall (e1: expr) (e2: expr), + or_cases e1 e2. + +Definition or_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return or_cases z1 z2 with + | Eop (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) => + or_case1 n1 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + or_case2 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + or_case3 t1 s t2 + | e1, e2 => + or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 n1 t1 n2 t2 => + if Int.eq (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32) + && same_expr_pure t1 t2 + then Eop (Oshift (Sror n2)) (t1:::Enil) + else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil) + | or_case2 s t1 t2 => + Eop (Oorshift s) (t2:::t1:::Enil) + | or_case3 t1 s t2 => + Eop (Oorshift s) (t1:::t2:::Enil) + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + +(* +Definition xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oxorshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oxorshift s) (t1:::t2:::Enil) + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. +*) + +Inductive xor_cases: forall (e1: expr) (e2: expr), Set := + | xor_case1: + forall s t1 t2, + xor_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | xor_case2: + forall t1 s t2, + xor_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | xor_default: + forall (e1: expr) (e2: expr), + xor_cases e1 e2. + +Definition xor_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return xor_cases z1 z2 with + | Eop (Oshift s) (t1:::Enil), t2 => + xor_case1 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + xor_case2 t1 s t2 + | e1, e2 => + xor_default e1 e2 + end. + +Definition xor (e1: expr) (e2: expr) := + match xor_match e1 e2 with + | xor_case1 s t1 t2 => + Eop (Oxorshift s) (t2:::t1:::Enil) + | xor_case2 t1 s t2 => + Eop (Oxorshift s) (t1:::t2:::Enil) + | xor_default e1 e2 => + Eop Oxor (e1:::e2:::Enil) + end. + +(** ** General shifts *) + +Inductive shift_cases: forall (e1: expr), Set := + | shift_case1: + forall (n2: int), + shift_cases (Eop (Ointconst n2) Enil) + | shift_default: + forall (e1: expr), + shift_cases e1. + +Definition shift_match (e1: expr) := + match e1 as z1 return shift_cases z1 with + | Eop (Ointconst n2) Enil => + shift_case1 n2 + | e1 => + shift_default e1 + end. + +Definition shl (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shlimm e1 n2 + | shift_default e2 => + Eop Oshl (e1:::e2:::Enil) + end. + +Definition shru (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shruimm e1 n2 + | shift_default e2 => + Eop Oshru (e1:::e2:::Enil) + end. + +Definition shr (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shrimm e1 n2 + | shift_default e2 => + Eop Oshr (e1:::e2:::Enil) + end. + +(** ** Truncations and sign extensions *) + +Inductive cast8signed_cases: forall (e1: expr), Set := + | cast8signed_case1: + forall (e2: expr), + cast8signed_cases (Eop Ocast8signed (e2 ::: Enil)) + | cast8signed_default: + forall (e1: expr), + cast8signed_cases e1. + +Definition cast8signed_match (e1: expr) := + match e1 as z1 return cast8signed_cases z1 with + | Eop Ocast8signed (e2 ::: Enil) => + cast8signed_case1 e2 + | e1 => + cast8signed_default e1 + end. + +Definition cast8signed (e: expr) := + match cast8signed_match e with + | cast8signed_case1 e1 => e + | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil) + end. + +Inductive cast8unsigned_cases: forall (e1: expr), Set := + | cast8unsigned_case1: + forall (e2: expr), + cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil)) + | cast8unsigned_default: + forall (e1: expr), + cast8unsigned_cases e1. + +Definition cast8unsigned_match (e1: expr) := + match e1 as z1 return cast8unsigned_cases z1 with + | Eop Ocast8unsigned (e2 ::: Enil) => + cast8unsigned_case1 e2 + | e1 => + cast8unsigned_default e1 + end. + +Definition cast8unsigned (e: expr) := + match cast8unsigned_match e with + | cast8unsigned_case1 e1 => e + | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil) + end. + +Inductive cast16signed_cases: forall (e1: expr), Set := + | cast16signed_case1: + forall (e2: expr), + cast16signed_cases (Eop Ocast16signed (e2 ::: Enil)) + | cast16signed_default: + forall (e1: expr), + cast16signed_cases e1. + +Definition cast16signed_match (e1: expr) := + match e1 as z1 return cast16signed_cases z1 with + | Eop Ocast16signed (e2 ::: Enil) => + cast16signed_case1 e2 + | e1 => + cast16signed_default e1 + end. + +Definition cast16signed (e: expr) := + match cast16signed_match e with + | cast16signed_case1 e1 => e + | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil) + end. + +Inductive cast16unsigned_cases: forall (e1: expr), Set := + | cast16unsigned_case1: + forall (e2: expr), + cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil)) + | cast16unsigned_default: + forall (e1: expr), + cast16unsigned_cases e1. + +Definition cast16unsigned_match (e1: expr) := + match e1 as z1 return cast16unsigned_cases z1 with + | Eop Ocast16unsigned (e2 ::: Enil) => + cast16unsigned_case1 e2 + | e1 => + cast16unsigned_default e1 + end. + +Definition cast16unsigned (e: expr) := + match cast16unsigned_match e with + | cast16unsigned_case1 e1 => e + | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil) + end. + +Inductive singleoffloat_cases: forall (e1: expr), Set := + | singleoffloat_case1: + forall (e2: expr), + singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil)) + | singleoffloat_default: + forall (e1: expr), + singleoffloat_cases e1. + +Definition singleoffloat_match (e1: expr) := + match e1 as z1 return singleoffloat_cases z1 with + | Eop Osingleoffloat (e2 ::: Enil) => + singleoffloat_case1 e2 + | e1 => + singleoffloat_default e1 + end. + +Definition singleoffloat (e: expr) := + match singleoffloat_match e with + | singleoffloat_case1 e1 => e + | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil) + end. + +(** ** Comparisons *) + +(* +Definition comp (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) + | t1, Eop (Ointconst n2) Enil => Eop (Ocmp (Ccompimm c n1)) (t1:::Enil) + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) + | _, _ => Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) + end. +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Set := + | 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_case3: + forall s t1 t2, + comp_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | comp_case4: + forall t1 s t2, + comp_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | comp_default: + forall (e1: expr) (e2: expr), + comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return comp_cases z1 z2 with + | Eop (Ointconst n1) Enil, t2 => + comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => + comp_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => + comp_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + comp_case4 t1 s t2 + | 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 (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompimm c n2)) (t1:::Enil) + | comp_case3 s t1 t2 => + Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) + | comp_case4 t1 s t2 => + Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2:::Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompuimm c n2)) (t1:::Enil) + | comp_case3 s t1 t2 => + Eop (Ocmp (Ccompushift (swap_comparison c) s)) (t2:::t1:::Enil) + | comp_case4 t1 s t2 => + Eop (Ocmp (Ccompushift c s)) (t1:::t2:::Enil) + | comp_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). + +(** ** Conditional expressions *) + +Fixpoint negate_condexpr (e: condexpr): condexpr := + match e with + | CEtrue => CEfalse + | CEfalse => CEtrue + | CEcond c el => CEcond (negate_condition c) el + | CEcondition e1 e2 e3 => + CEcondition e1 (negate_condexpr e2) (negate_condexpr e3) + end. + + +Definition is_compare_neq_zero (c: condition) : bool := + match c with + | Ccompimm Cne n => Int.eq n Int.zero + | Ccompuimm Cne n => Int.eq n Int.zero + | _ => false + end. + +Definition is_compare_eq_zero (c: condition) : bool := + match c with + | Ccompimm Ceq n => Int.eq n Int.zero + | Ccompuimm Ceq n => Int.eq n Int.zero + | _ => false + end. + +Fixpoint condexpr_of_expr (e: expr) : condexpr := + match e with + | Eop (Ointconst n) Enil => + if Int.eq n Int.zero then CEfalse else CEtrue + | Eop (Ocmp c) (e1 ::: Enil) => + if is_compare_neq_zero c then + condexpr_of_expr e1 + else if is_compare_eq_zero c then + negate_condexpr (condexpr_of_expr e1) + else + CEcond c (e1 ::: Enil) + | Eop (Ocmp c) el => + CEcond c el + | Econdition ce e1 e2 => + CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) + | _ => + CEcond (Ccompimm Cne Int.zero) (e:::Enil) + end. + +(** ** Recognition of addressing modes for load and store operations *) + +(* +Definition addressing (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop (Oaddshift s) (e1:::e2:::Enil) => (Aindexed2shift s, e1:::e2:::Enil) + | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Int.zero, e:::Enil) + end. +*) + +Inductive addressing_cases: forall (e: expr), Set := + | addressing_case2: + forall n, + addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case3: + forall n e1, + addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case4: + forall s e1 e2, + addressing_cases (Eop (Oaddshift s) (e1:::e2:::Enil)) + | addressing_case5: + forall e1 e2, + addressing_cases (Eop Oadd (e1:::e2:::Enil)) + | addressing_default: + forall (e: expr), + addressing_cases e. + +Definition addressing_match (e: expr) := + match e as z1 return addressing_cases z1 with + | Eop (Oaddrstack n) Enil => + addressing_case2 n + | Eop (Oaddimm n) (e1:::Enil) => + addressing_case3 n e1 + | Eop (Oaddshift s) (e1:::e2:::Enil) => + addressing_case4 s e1 e2 + | Eop Oadd (e1:::e2:::Enil) => + addressing_case5 e1 e2 + | e => + addressing_default e + end. + +(** We do not recognize the [Aindexed2] and [Aindexed2shift] modes + for floating-point accesses, since these are not supported + by the hardware and emulated inefficiently in [ARMgen]. *) + +Definition is_float_addressing (chunk: memory_chunk): bool := + match chunk with + | Mfloat32 => true + | Mfloat64 => true + | _ => false + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case2 n => + (Ainstack n, Enil) + | addressing_case3 n e1 => + (Aindexed n, e1:::Enil) + | addressing_case4 s e1 e2 => + if is_float_addressing chunk + then (Aindexed Int.zero, Eop (Oaddshift s) (e1:::e2:::Enil) ::: Enil) + else (Aindexed2shift s, e1:::e2:::Enil) + | addressing_case5 e1 e2 => + if is_float_addressing chunk + then (Aindexed Int.zero, Eop Oadd (e1:::e2:::Enil) ::: Enil) + else (Aindexed2, e1:::e2:::Enil) + | addressing_default e => + (Aindexed Int.zero, e:::Enil) + end. + +Definition load (chunk: memory_chunk) (e1: expr) := + match addressing chunk e1 with + | (mode, args) => Eload chunk mode args + end. + +Definition store (chunk: memory_chunk) (e1 e2: expr) := + match addressing chunk e1 with + | (mode, args) => Sstore chunk mode args e2 + end. + +(** * Translation from Cminor to CminorSel *) + +(** Instruction selection for operator applications *) + +Definition sel_constant (cst: Cminor.constant) : expr := + match cst with + | Cminor.Ointconst n => Eop (Ointconst n) Enil + | Cminor.Ofloatconst f => Eop (Ofloatconst f) Enil + | Cminor.Oaddrsymbol id ofs => Eop (Oaddrsymbol id ofs) Enil + | Cminor.Oaddrstack ofs => Eop (Oaddrstack ofs) Enil + end. + +Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := + match op with + | Cminor.Ocast8unsigned => cast8unsigned arg + | Cminor.Ocast8signed => cast8signed arg + | Cminor.Ocast16unsigned => cast16unsigned arg + | Cminor.Ocast16signed => cast16signed arg + | Cminor.Onegint => Eop (Orsubimm Int.zero) (arg ::: Enil) + | Cminor.Onotbool => notbool arg + | Cminor.Onotint => notint arg + | Cminor.Onegf => Eop Onegf (arg ::: Enil) + | Cminor.Oabsf => Eop Oabsf (arg ::: Enil) + | Cminor.Osingleoffloat => singleoffloat arg + | Cminor.Ointoffloat => Eop Ointoffloat (arg ::: Enil) + | Cminor.Ointuoffloat => Eop Ointuoffloat (arg ::: Enil) + | Cminor.Ofloatofint => Eop Ofloatofint (arg ::: Enil) + | Cminor.Ofloatofintu => Eop Ofloatofintu (arg ::: Enil) + end. + +Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := + match op with + | Cminor.Oadd => add arg1 arg2 + | Cminor.Osub => sub arg1 arg2 + | Cminor.Omul => mul arg1 arg2 + | Cminor.Odiv => divs arg1 arg2 + | Cminor.Odivu => divu arg1 arg2 + | Cminor.Omod => mods arg1 arg2 + | Cminor.Omodu => modu arg1 arg2 + | Cminor.Oand => and arg1 arg2 + | Cminor.Oor => or arg1 arg2 + | Cminor.Oxor => xor arg1 arg2 + | Cminor.Oshl => shl arg1 arg2 + | Cminor.Oshr => shr arg1 arg2 + | Cminor.Oshru => shru arg1 arg2 + | Cminor.Oaddf => Eop Oaddf (arg1 ::: arg2 ::: Enil) + | Cminor.Osubf => Eop Osubf (arg1 ::: arg2 ::: Enil) + | Cminor.Omulf => Eop Omulf (arg1 ::: arg2 ::: Enil) + | Cminor.Odivf => Eop Odivf (arg1 ::: arg2 ::: Enil) + | Cminor.Ocmp c => comp c arg1 arg2 + | Cminor.Ocmpu c => compu c arg1 arg2 + | Cminor.Ocmpf c => compf c arg1 arg2 + end. + +(** Conversion from Cminor expression to Cminorsel expressions *) + +Fixpoint sel_expr (a: Cminor.expr) : expr := + match a with + | Cminor.Evar id => Evar id + | Cminor.Econst cst => sel_constant cst + | Cminor.Eunop op arg => sel_unop op (sel_expr arg) + | Cminor.Ebinop op arg1 arg2 => sel_binop op (sel_expr arg1) (sel_expr arg2) + | Cminor.Eload chunk addr => load chunk (sel_expr addr) + | Cminor.Econdition cond ifso ifnot => + Econdition (condexpr_of_expr (sel_expr cond)) + (sel_expr ifso) (sel_expr ifnot) + end. + +Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := + match al with + | nil => Enil + | a :: bl => Econs (sel_expr a) (sel_exprlist bl) + end. + +(** Conversion from Cminor statements to Cminorsel statements. *) + +Fixpoint sel_stmt (s: Cminor.stmt) : stmt := + match s with + | Cminor.Sskip => Sskip + | Cminor.Sassign id e => Sassign id (sel_expr e) + | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) + | Cminor.Scall optid sg fn args => + Scall optid sg (sel_expr fn) (sel_exprlist args) + | Cminor.Stailcall sg fn args => + Stailcall sg (sel_expr fn) (sel_exprlist args) + | Cminor.Salloc id b => Salloc id (sel_expr b) + | Cminor.Sseq s1 s2 => Sseq (sel_stmt s1) (sel_stmt s2) + | Cminor.Sifthenelse e ifso ifnot => + Sifthenelse (condexpr_of_expr (sel_expr e)) + (sel_stmt ifso) (sel_stmt ifnot) + | Cminor.Sloop body => Sloop (sel_stmt body) + | Cminor.Sblock body => Sblock (sel_stmt body) + | Cminor.Sexit n => Sexit n + | Cminor.Sswitch e cases dfl => Sswitch (sel_expr e) cases dfl + | Cminor.Sreturn None => Sreturn None + | Cminor.Sreturn (Some e) => Sreturn (Some (sel_expr e)) + | Cminor.Slabel lbl body => Slabel lbl (sel_stmt body) + | Cminor.Sgoto lbl => Sgoto lbl + end. + +(** Conversion of functions and programs. *) + +Definition sel_function (f: Cminor.function) : function := + mkfunction + f.(Cminor.fn_sig) + f.(Cminor.fn_params) + f.(Cminor.fn_vars) + f.(Cminor.fn_stackspace) + (sel_stmt f.(Cminor.fn_body)). + +Definition sel_fundef (f: Cminor.fundef) : fundef := + transf_fundef sel_function f. + +Definition sel_program (p: Cminor.program) : program := + transform_program sel_fundef p. + + + diff --git a/arm/Selectionproof.v b/arm/Selectionproof.v new file mode 100644 index 0000000..e487d15 --- /dev/null +++ b/arm/Selectionproof.v @@ -0,0 +1,1475 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import Selection. + +Open Local Scope selection_scope. + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** * Lifting of let-bound variables *) + +Inductive insert_lenv: letenv -> nat -> val -> letenv -> Prop := + | insert_lenv_0: + forall le v, + insert_lenv le O v (v :: le) + | insert_lenv_S: + forall le p w le' v, + insert_lenv le p w le' -> + insert_lenv (v :: le) (S p) w (v :: le'). + +Lemma insert_lenv_lookup1: + forall le p w le', + insert_lenv le p w le' -> + forall n v, + nth_error le n = Some v -> (p > n)%nat -> + nth_error le' n = Some v. +Proof. + induction 1; intros. + omegaContradiction. + destruct n; simpl; simpl in H0. auto. + apply IHinsert_lenv. auto. omega. +Qed. + +Lemma insert_lenv_lookup2: + forall le p w le', + insert_lenv le p w le' -> + forall n v, + nth_error le n = Some v -> (p <= n)%nat -> + nth_error le' (S n) = Some v. +Proof. + induction 1; intros. + simpl. assumption. + simpl. destruct n. omegaContradiction. + apply IHinsert_lenv. exact H0. omega. +Qed. + +Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition + eval_Elet eval_Eletvar + eval_CEtrue eval_CEfalse eval_CEcond + eval_CEcondition eval_Enil eval_Econs: evalexpr. + +Lemma eval_lift_expr: + forall w le a v, + eval_expr ge sp e m le a v -> + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v. +Proof. + intro w. + apply (eval_expr_ind3 ge sp e m + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v) + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_condexpr ge sp e m le' (lift_condexpr p a) v) + (fun le al vl => + forall p le', insert_lenv le p w le' -> + eval_exprlist ge sp e m le' (lift_exprlist p al) vl)); + simpl; intros; eauto with evalexpr. + + destruct v1; eapply eval_Econdition; + eauto with evalexpr; simpl; eauto with evalexpr. + + eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. + + case (le_gt_dec p n); intro. + apply eval_Eletvar. eapply insert_lenv_lookup2; eauto. + apply eval_Eletvar. eapply insert_lenv_lookup1; eauto. + + destruct vb1; eapply eval_CEcondition; + eauto with evalexpr; simpl; eauto with evalexpr. +Qed. + +Lemma eval_lift: + forall le a v w, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m (w::le) (lift a) v. +Proof. + intros. unfold lift. eapply eval_lift_expr. + eexact H. apply insert_lenv_0. +Qed. + +Hint Resolve eval_lift: evalexpr. + +(** * 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 TrivialOp cstr := unfold cstr; intros; EvalOp. + +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. + +(** * Correctness of the smart constructors *) + +(** 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. +*) + +Theorem eval_notint: + forall le a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (notint a) (Vint (Int.not x)). +Proof. + unfold notint; intros until x; case (notint_match a); intros; InvEval. + EvalOp. simpl. congruence. + subst x. rewrite Int.not_involutive. auto. + EvalOp. simpl. subst x. rewrite Int.not_involutive. auto. + EvalOp. +Qed. + +Lemma eval_notbool_base: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). +Proof. + TrivialOp notbool_base. simpl. + inv H0. + rewrite Int.eq_false; auto. + rewrite Int.eq_true; auto. + reflexivity. +Qed. + +Hint Resolve Val.bool_of_true_val Val.bool_of_false_val + Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. + +Theorem eval_notbool: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Proof. + induction a; simpl; intros; try (eapply eval_notbool_base; eauto). + destruct o; try (eapply eval_notbool_base; eauto). + + destruct e0. InvEval. + inv H0. rewrite Int.eq_false; auto. + simpl; eauto with evalexpr. + rewrite Int.eq_true; simpl; eauto with evalexpr. + eapply eval_notbool_base; eauto. + + inv H. eapply eval_Eop; eauto. + simpl. assert (eval_condition c vl m = Some b). + generalize H6. simpl. + case (eval_condition c vl m); intros. + destruct b0; inv H1; inversion H0; auto; congruence. + congruence. + rewrite (Op.eval_negate_condition _ _ _ H). + destruct b; reflexivity. + + inv H. eapply eval_Econdition; eauto. + destruct v1; eauto. +Qed. + +Theorem eval_addimm: + forall le n a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). +Proof. + unfold addimm; intros until x. + generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. + subst n. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; EvalOp; simpl. + rewrite Int.add_commut. auto. + destruct (Genv.find_symbol ge s); discriminate. + destruct sp; simpl in H1; discriminate. + subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. +Qed. + +Theorem eval_addimm_ptr: + forall le n a b ofs, + eval_expr ge sp e m le a (Vptr b ofs) -> + eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). +Proof. + unfold addimm; intros until ofs. + generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. + subst n. rewrite Int.add_zero. auto. + case (addimm_match a); intros; InvEval; EvalOp; simpl. + destruct (Genv.find_symbol ge s). + rewrite Int.add_commut. congruence. + discriminate. + destruct sp; simpl in H1; try discriminate. + inv H1. simpl. decEq. decEq. + rewrite Int.add_assoc. decEq. apply Int.add_commut. + subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. +Qed. + +Theorem eval_add: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). +Proof. + intros until y. + unfold add; case (add_match a b); intros; InvEval. + rewrite Int.add_commut. apply eval_addimm. auto. + replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + replace (Int.add x y) with (Int.add (Int.add i y) n1). + apply eval_addimm. EvalOp. + subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + apply eval_addimm. auto. + replace (Int.add x y) with (Int.add (Int.add x i) n2). + apply eval_addimm. EvalOp. + subst y. rewrite Int.add_assoc. auto. + EvalOp. simpl. subst x. rewrite Int.add_commut. auto. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_add_ptr: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + replace (Int.add x y) with (Int.add (Int.add i y) n1). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + apply eval_addimm_ptr. auto. + replace (Int.add x y) with (Int.add (Int.add x i) n2). + apply eval_addimm_ptr. EvalOp. + subst y. rewrite Int.add_assoc. auto. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_add_ptr_2: + forall le a b x p y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + apply eval_addimm_ptr. auto. + replace (Int.add y x) with (Int.add (Int.add i i0) (Int.add n1 n2)). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. + rewrite (Int.add_commut n1 n2). apply Int.add_permut. + replace (Int.add y x) with (Int.add (Int.add y i) n1). + apply eval_addimm_ptr. EvalOp. + subst x. repeat rewrite Int.add_assoc. auto. + replace (Int.add y x) with (Int.add (Int.add i x) n2). + apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. + subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm. assumption. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm. EvalOp. + subst x. rewrite Int.sub_add_l. auto. + replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm. EvalOp. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. + EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub_ptr_int: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm_ptr. assumption. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). + apply eval_addimm_ptr. EvalOp. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm_ptr. EvalOp. + subst x. rewrite Int.sub_add_l. auto. + replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm_ptr. EvalOp. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub_ptr_ptr: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). + apply eval_addimm. EvalOp. + simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm. EvalOp. + simpl. unfold eq_block. rewrite zeq_true. auto. + subst x. rewrite Int.sub_add_l. auto. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm. EvalOp. + simpl. unfold eq_block. rewrite zeq_true. auto. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. +Qed. + +Theorem eval_shlimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). +Proof. + intros until x. unfold shlimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shl_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shlimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shl_shl. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Theorem eval_shruimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). +Proof. + intros until x. unfold shruimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shru_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shruimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shru_shru. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Theorem eval_shrimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)). +Proof. + intros until x. unfold shrimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shr_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shrimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shr_shr. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Lemma eval_mulimm_base: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). +Proof. + intros; unfold mulimm_base. + generalize (Int.one_bits_decomp n). + generalize (Int.one_bits_range n). + change (Z_of_nat wordsize) with 32. + destruct (Int.one_bits n). + intros. EvalOp. constructor. EvalOp. simpl; reflexivity. + constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. + destruct l. + intros. rewrite H1. simpl. + rewrite Int.add_zero. rewrite <- Int.shl_mul. + apply eval_shlimm. auto. auto with coqlib. + destruct l. + intros. apply eval_Elet with (Vint x). auto. + rewrite H1. simpl. rewrite Int.add_zero. + rewrite Int.mul_add_distr_r. + rewrite <- Int.shl_mul. + rewrite <- Int.shl_mul. + apply eval_add. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + intros. EvalOp. constructor. EvalOp. simpl; reflexivity. + constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. +Qed. + +Theorem eval_mulimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). +Proof. + intros until x; unfold mulimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + subst n. rewrite Int.mul_zero. + intro. EvalOp. + generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. + subst n. rewrite Int.mul_one. auto. + case (mulimm_match a); intros; InvEval. + EvalOp. rewrite Int.mul_commut. reflexivity. + replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). + apply eval_addimm. apply eval_mulimm_base. auto. + subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. + apply eval_mulimm_base. assumption. +Qed. + +Theorem eval_mul: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Proof. + intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Int.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + EvalOp. +Qed. + +Theorem eval_divs_base: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (Eop Odiv (a ::: b ::: Enil)) (Vint (Int.divs x y)). +Proof. + intros. EvalOp; simpl. + predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. +Qed. + +Theorem eval_divs: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). +Proof. + intros until y. + unfold divs; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y); intros. + caseEq (Int.ltu i (Int.repr 31)); intros. + EvalOp. simpl. unfold Int.ltu. rewrite zlt_true. + rewrite (Int.divs_pow2 x y i H0). auto. + exploit Int.ltu_inv; eauto. + change (Int.unsigned (Int.repr 31)) with 31. + change (Int.unsigned (Int.repr 32)) with 32. + omega. + apply eval_divs_base. auto. EvalOp. auto. + apply eval_divs_base. auto. EvalOp. auto. + apply eval_divs_base; auto. +Qed. + +Lemma eval_mod_aux: + forall divop semdivop, + (forall sp x y m, + y <> Int.zero -> + eval_operation ge sp divop (Vint x :: Vint y :: nil) m = + Some (Vint (semdivop x y))) -> + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mod_aux divop a b) + (Vint (Int.sub x (Int.mul (semdivop x y) y))). +Proof. + intros; unfold mod_aux. + eapply eval_Elet. eexact H0. eapply eval_Elet. + apply eval_lift. eexact H1. + eapply eval_Eop. eapply eval_Econs. + eapply eval_Eletvar. simpl; reflexivity. + eapply eval_Econs. eapply eval_Eop. + eapply eval_Econs. eapply eval_Eop. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. + apply H. assumption. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. + simpl; reflexivity. apply eval_Enil. + reflexivity. +Qed. + +Theorem eval_mods: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). +Proof. + intros; unfold mods. + rewrite Int.mods_divs. + eapply eval_mod_aux; eauto. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. +Qed. + +Lemma eval_divu_base: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (Vint (Int.divu x y)). +Proof. + intros. EvalOp. simpl. + predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. +Qed. + +Theorem eval_divu: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Proof. + intros until y. + unfold divu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.divu_pow2 x y i H0). + apply eval_shruimm. auto. + apply Int.is_power2_range with y. auto. + intros. apply eval_divu_base. auto. EvalOp. auto. + eapply eval_divu_base; eauto. +Qed. + +Theorem eval_modu: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). +Proof. + intros until y; unfold modu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.modu_and x y i H0). + EvalOp. + intro. rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. + auto. EvalOp. auto. auto. + rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. auto. auto. auto. auto. +Qed. + +Theorem eval_and: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Proof. + intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +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. + +Lemma eval_or: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). +Proof. + intros until y; unfold or; case (or_match a b); intros; InvEval. + caseEq (Int.eq (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32) + && same_expr_pure t1 t2); intro. + destruct (andb_prop _ _ H1). + generalize (Int.eq_spec (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32)). + rewrite H4. intro. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. + simpl. EvalOp. simpl. decEq. decEq. apply Int.or_ror. + destruct n1; auto. destruct n2; auto. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. + econstructor; eauto with evalexpr. + simpl. congruence. + EvalOp. simpl. rewrite Int.or_commut. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_xor: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). +Proof. + intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Int.xor_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_shl: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Proof. + intros until y; unfold shl; case (shift_match b); intros. + InvEval. apply eval_shlimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_shru: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Proof. + intros until y; unfold shru; case (shift_match b); intros. + InvEval. apply eval_shruimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_shr: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). +Proof. + intros until y; unfold shr; case (shift_match b); intros. + InvEval. apply eval_shrimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_cast8signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). +Proof. + intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast8unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). +Proof. + intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). +Proof. + intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). +Proof. + intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_singleoffloat: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). +Proof. + intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. + EvalOp. +Qed. + +Theorem eval_comp_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). +Proof. + intros until y. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. rewrite Int.swap_cmp. rewrite H. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. rewrite H0. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. +Qed. + +Remark eval_compare_null_trans: + forall c x v, + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + match eval_compare_null c x with + | Some true => Some Vtrue + | Some false => Some Vfalse + | None => None (A:=val) + end = Some v. +Proof. + unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. + destruct (Int.eq x Int.zero); try discriminate. + destruct c; try discriminate; auto. +Qed. + +Theorem eval_comp_ptr_int: + forall le c a x1 x2 b y v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vint y) -> + (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. apply eval_compare_null_trans; auto. + EvalOp. simpl. rewrite H0. apply eval_compare_null_trans; auto. + EvalOp. simpl. apply eval_compare_null_trans; auto. +Qed. + +Remark eval_swap_compare_null_trans: + forall c x v, + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + match eval_compare_null (swap_comparison c) x with + | Some true => Some Vtrue + | Some false => Some Vfalse + | None => None (A:=val) + end = Some v. +Proof. + unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. + destruct (Int.eq x Int.zero); try discriminate. + destruct c; simpl; try discriminate; auto. +Qed. + +Theorem eval_comp_int_ptr: + forall le c a x b y1 y2 v, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. apply eval_swap_compare_null_trans; auto. + EvalOp. simpl. rewrite H. apply eval_swap_compare_null_trans; auto. + EvalOp. simpl. apply eval_compare_null_trans; auto. +Qed. + +Theorem eval_comp_ptr_ptr: + forall le c a x1 x2 b y1 y2, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 = y1 -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. simpl. + subst y1. rewrite dec_eq_true. + destruct (Int.cmp c x2 y2); reflexivity. +Qed. + +Theorem eval_comp_ptr_ptr_2: + forall le c a x1 x2 b y1 y2 v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 <> y1 -> + Cminor.eval_compare_mismatch c = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. +Qed. + + +Theorem eval_compu: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H0. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + +Theorem eval_compf: + forall le c a x b y, + eval_expr ge sp e m le a (Vfloat x) -> + eval_expr ge sp e m le b (Vfloat y) -> + eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Proof. + intros. unfold compf. EvalOp. simpl. + destruct (Float.cmp c x y); reflexivity. +Qed. + +Lemma negate_condexpr_correct: + forall le a b, + eval_condexpr ge sp e m le a b -> + eval_condexpr ge sp e m le (negate_condexpr a) (negb b). +Proof. + induction 1; simpl. + constructor. + constructor. + econstructor. eauto. apply eval_negate_condition. auto. + econstructor. eauto. destruct vb1; auto. +Qed. + +Scheme expr_ind2 := Induction for expr Sort Prop + with exprlist_ind2 := Induction for exprlist Sort Prop. + +Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop := + match el with + | Enil => True + | Econs e el' => P e /\ forall_exprlist P el' + end. + +Lemma expr_induction_principle: + forall (P: expr -> Prop), + (forall i : ident, P (Evar i)) -> + (forall (o : operation) (e : exprlist), + forall_exprlist P e -> P (Eop o e)) -> + (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist), + forall_exprlist P e -> P (Eload m a e)) -> + (forall (c : condexpr) (e : expr), + P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) -> + (forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) -> + (forall n : nat, P (Eletvar n)) -> + forall e : expr, P e. +Proof. + intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto. + simpl. auto. + intros. simpl. auto. +Qed. + +Lemma eval_base_condition_of_expr: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le + (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) + b. +Proof. + intros. + eapply eval_CEcond. eauto with evalexpr. + inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. +Qed. + +Lemma is_compare_neq_zero_correct: + forall c v b, + is_compare_neq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v b. +Proof. + intros. + destruct c; simpl in H; try discriminate; + destruct c; simpl in H; try discriminate; + generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. constructor. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. +Qed. + +Lemma is_compare_eq_zero_correct: + forall c v b, + is_compare_eq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v (negb b). +Proof. + intros. apply is_compare_neq_zero_correct with (negate_condition c). + destruct c; simpl in H; simpl; try discriminate; + destruct c; simpl; try discriminate; auto. + apply eval_negate_condition; auto. +Qed. + +Lemma eval_condition_of_expr: + forall a le v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le (condexpr_of_expr a) b. +Proof. + intro a0; pattern a0. + apply expr_induction_principle; simpl; intros; + try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct e0. InvEval. + inversion H1. + rewrite Int.eq_false; auto. constructor. + subst i; rewrite Int.eq_true. constructor. + eapply eval_base_condition_of_expr; eauto. + + inv H0. simpl in H7. + assert (eval_condition c vl m = Some b). + destruct (eval_condition c vl m); try discriminate. + destruct b0; inv H7; inversion H1; congruence. + assert (eval_condexpr ge sp e m le (CEcond c e0) b). + eapply eval_CEcond; eauto. + destruct e0; auto. destruct e1; auto. + simpl in H. destruct H. + inv H5. inv H11. + + case_eq (is_compare_neq_zero c); intros. + eapply H; eauto. + apply is_compare_neq_zero_correct with c; auto. + + case_eq (is_compare_eq_zero c); intros. + replace b with (negb (negb b)). apply negate_condexpr_correct. + eapply H; eauto. + apply is_compare_eq_zero_correct with c; auto. + apply negb_involutive. + + auto. + + inv H1. destruct v1; eauto with evalexpr. +Qed. + +Lemma 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. + exists (Vptr b0 i :: nil). split. eauto with evalexpr. + simpl. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. congruence. + exists (Vptr b0 i :: Vint i0 :: nil). + split. eauto with evalexpr. simpl. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. congruence. + exists (Vint i :: Vptr b0 i0 :: nil). + split. eauto with evalexpr. simpl. + rewrite Int.add_commut. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. congruence. + exists (Vptr b0 i :: Vint i0 :: nil). + split. eauto with evalexpr. simpl. congruence. + exists (v :: nil). split. eauto with evalexpr. + subst v. simpl. rewrite Int.add_zero. auto. +Qed. + +Lemma eval_load: + forall le a v chunk v', + eval_expr ge sp e m le a v -> + Mem.loadv chunk m v = Some v' -> + eval_expr ge sp e m le (load chunk a) v'. +Proof. + intros. generalize H0; destruct v; simpl; intro; try discriminate. + unfold load. + generalize (eval_addressing _ chunk _ _ _ _ H (refl_equal _)). + destruct (addressing chunk a). intros [vl [EV EQ]]. + eapply eval_Eload; eauto. +Qed. + +Lemma eval_store: + forall chunk a1 a2 v1 v2 f k m', + eval_expr ge sp e m nil a1 v1 -> + eval_expr ge sp e m nil a2 v2 -> + Mem.storev chunk m v1 v2 = Some m' -> + step ge (State f (store chunk a1 a2) k sp e m) + E0 (State f Sskip k sp e m'). +Proof. + intros. generalize H1; destruct v1; simpl; intro; try discriminate. + unfold store. + generalize (eval_addressing _ chunk _ _ _ _ H (refl_equal _)). + destruct (addressing chunk a1). intros [vl [EV EQ]]. + eapply step_store; eauto. +Qed. + +(** * Correctness of instruction selection for operators *) + +(** We now prove a semantic preservation result for the [sel_unop] + and [sel_binop] selection functions. The proof exploits + the results of the previous section. *) + +Lemma eval_sel_unop: + forall le op a1 v1 v, + eval_expr ge sp e m le a1 v1 -> + eval_unop op v1 = Some v -> + eval_expr ge sp e m le (sel_unop op a1) v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + apply eval_cast8unsigned; auto. + apply eval_cast8signed; auto. + apply eval_cast16unsigned; auto. + apply eval_cast16signed; auto. + EvalOp. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro. + change true with (negb false). eapply eval_notbool; eauto. subst i; constructor. + change false with (negb true). eapply eval_notbool; eauto. constructor; auto. + change Vfalse with (Val.of_bool (negb true)). + eapply eval_notbool; eauto. constructor. + apply eval_notint; auto. + EvalOp. + EvalOp. + apply eval_singleoffloat; auto. + EvalOp. + EvalOp. + EvalOp. + EvalOp. +Qed. + +Lemma eval_sel_binop: + forall le op a1 a2 v1 v2 v, + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_binop op v1 v2 m = Some v -> + eval_expr ge sp e m le (sel_binop op a1 a2) v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + apply eval_add; auto. + apply eval_add_ptr_2; auto. + apply eval_add_ptr; auto. + apply eval_sub; auto. + apply eval_sub_ptr_int; auto. + destruct (eq_block b b0); inv H1. + eapply eval_sub_ptr_ptr; eauto. + apply eval_mul; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divs; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divu; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_mods; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_modu; eauto. + apply eval_and; auto. + apply eval_or; auto. + apply eval_xor; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shl; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shr; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shru; auto. + EvalOp. + EvalOp. + EvalOp. + EvalOp. + apply eval_comp_int; auto. + eapply eval_comp_int_ptr; eauto. + eapply eval_comp_ptr_int; eauto. + generalize H1; clear H1. + case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros. + destruct (eq_block b b0); inv H2. + eapply eval_comp_ptr_ptr; eauto. + eapply eval_comp_ptr_ptr_2; eauto. + discriminate. + eapply eval_compu; eauto. + eapply eval_compf; eauto. +Qed. + +End CMCONSTR. + +(** * Semantic preservation for instruction selection. *) + +Section PRESERVATION. + +Variable prog: Cminor.program. +Let tprog := sel_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +(** Relationship between the global environments for the original + CminorSel program and the generated RTL program. *) + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros; unfold ge, tge, tprog, sel_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: Cminor.fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (sel_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf sel_fundef H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: Cminor.fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (sel_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf sel_fundef H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (sel_fundef f) = Cminor.funsig f. +Proof. + intros. destruct f; reflexivity. +Qed. + +(** Semantic preservation for expressions. *) + +Lemma sel_expr_correct: + forall sp e m a v, + Cminor.eval_expr ge sp e m a v -> + forall le, + eval_expr tge sp e m le (sel_expr a) v. +Proof. + induction 1; intros; simpl. + (* Evar *) + constructor; auto. + (* Econst *) + destruct cst; simpl; simpl in H; (econstructor; [constructor|simpl;auto]). + rewrite symbols_preserved. auto. + (* Eunop *) + eapply eval_sel_unop; eauto. + (* Ebinop *) + eapply eval_sel_binop; eauto. + (* Eload *) + eapply eval_load; eauto. + (* Econdition *) + econstructor; eauto. eapply eval_condition_of_expr; eauto. + destruct b1; auto. +Qed. + +Hint Resolve sel_expr_correct: evalexpr. + +Lemma sel_exprlist_correct: + forall sp e m a v, + Cminor.eval_exprlist ge sp e m a v -> + forall le, + eval_exprlist tge sp e m le (sel_exprlist a) v. +Proof. + induction 1; intros; simpl; constructor; auto with evalexpr. +Qed. + +Hint Resolve sel_exprlist_correct: evalexpr. + +(** Semantic preservation for terminating function calls and statements. *) + +Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := + match k with + | Cminor.Kstop => Kstop + | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1) + | Cminor.Kblock k1 => Kblock (sel_cont k1) + | Cminor.Kcall id f sp e k1 => + Kcall id (sel_function f) sp e (sel_cont k1) + end. + +Inductive match_states: Cminor.state -> CminorSel.state -> Prop := + | match_state: forall f s k s' k' sp e m, + s' = sel_stmt s -> + k' = sel_cont k -> + match_states + (Cminor.State f s k sp e m) + (State (sel_function f) s' k' sp e m) + | match_callstate: forall f args k k' m, + k' = sel_cont k -> + match_states + (Cminor.Callstate f args k m) + (Callstate (sel_fundef f) args k' m) + | match_returnstate: forall v k k' m, + k' = sel_cont k -> + match_states + (Cminor.Returnstate v k m) + (Returnstate v k' m). + +Remark call_cont_commut: + forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). +Proof. + induction k; simpl; auto. +Qed. + +Remark find_label_commut: + forall lbl s k, + find_label lbl (sel_stmt s) (sel_cont k) = + option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk))) + (Cminor.find_label lbl s k). +Proof. + induction s; intros; simpl; auto. + unfold store. destruct (addressing m (sel_expr e)); auto. + change (Kseq (sel_stmt s2) (sel_cont k)) + with (sel_cont (Cminor.Kseq s2 k)). + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 k); auto. + change (Kseq (Sloop (sel_stmt s)) (sel_cont k)) + with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). + auto. + change (Kblock (sel_cont k)) + with (sel_cont (Cminor.Kblock k)). + auto. + destruct o; auto. + destruct (ident_eq lbl l); auto. +Qed. + +Lemma sel_step_correct: + forall S1 t S2, Cminor.step ge S1 t S2 -> + forall T1, match_states S1 T1 -> + exists T2, step tge T1 t T2 /\ match_states S2 T2. +Proof. + induction 1; intros T1 ME; inv ME; simpl; + try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). + + (* skip call *) + econstructor; split. + econstructor. destruct k; simpl in H; simpl; auto. + rewrite <- H0; reflexivity. + constructor; auto. + (* assign *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split. + constructor. auto with evalexpr. + constructor; auto. + (* store *) + econstructor; split. + eapply eval_store; eauto with evalexpr. + constructor; auto. + (* Scall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. + (* Stailcall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. apply call_cont_commut. + (* Salloc *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split. + econstructor; eauto with evalexpr. + constructor; auto. + (* Sifthenelse *) + exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split. + constructor. eapply eval_condition_of_expr; eauto with evalexpr. + constructor; auto. destruct b; auto. + (* Sreturn None *) + econstructor; split. + econstructor. rewrite <- H; reflexivity. + constructor; auto. apply call_cont_commut. + (* Sreturn Some *) + econstructor; split. + econstructor. simpl. auto. eauto with evalexpr. + constructor; auto. apply call_cont_commut. + (* Sgoto *) + econstructor; split. + econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. + rewrite H. simpl. reflexivity. + constructor; auto. +Qed. + +Lemma sel_initial_states: + forall S, Cminor.initial_state prog S -> + exists R, initial_state tprog R /\ match_states S R. +Proof. + induction 1. + econstructor; split. + econstructor. + simpl. fold tge. rewrite symbols_preserved. eexact H. + apply function_ptr_translated. eauto. + rewrite <- H1. apply sig_function_translated; auto. + unfold tprog, sel_program. rewrite Genv.init_mem_transf. + constructor; auto. +Qed. + +Lemma sel_final_states: + forall S R r, + match_states S R -> Cminor.final_state S r -> final_state R r. +Proof. + intros. inv H0. inv H. simpl. constructor. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh. +Proof. + unfold CminorSel.exec_program, Cminor.exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact sel_initial_states. + eexact sel_final_states. + exact sel_step_correct. +Qed. + +End PRESERVATION. diff --git a/arm/linux/Conventions.v b/arm/linux/Conventions.v new file mode 100644 index 0000000..0342521 --- /dev/null +++ b/arm/linux/Conventions.v @@ -0,0 +1,858 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib. +Require Import AST. +Require Import Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Temporaries used for spilling, reloading, and parallel move operations. +- Allocatable registers, that can be assigned to RTL pseudo-registers. + These are further divided into: +-- 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 PowerPC application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition int_caller_save_regs := + R0 :: R1 :: R2 :: R3 :: nil. + +Definition float_caller_save_regs := + F0 :: F1 :: nil. + +Definition int_callee_save_regs := + R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R11 :: nil. + +Definition float_callee_save_regs := + F4 :: F5 :: F6 :: F7 :: nil. + +Definition destroyed_at_call_regs := + int_caller_save_regs ++ float_caller_save_regs. + +Definition destroyed_at_call := + List.map R destroyed_at_call_regs. + +Definition int_temporaries := IT1 :: IT2 :: nil. + +Definition float_temporaries := FT1 :: FT2 :: nil. + +Definition temporaries := + R IT1 :: R IT2 :: R FT1 :: R FT2 :: nil. + +(** The [index_int_callee_save] and [index_float_callee_save] associate + a unique positive integer to callee-save registers. This integer is + used in [Stacking] to determine where to save these registers in + the activation record if they are used by the current function. *) + +Definition index_int_callee_save (r: mreg) := + match r with + | R4 => 0 | R5 => 1 | R6 => 2 | R7 => 3 + | R8 => 4 | R9 => 5 | R11 => 6 + | _ => -1 + end. + +Definition index_float_callee_save (r: mreg) := + match r with + | F4 => 0 | F5 => 1 | F6 => 2 | F7 => 3 + | _ => -1 + end. + +Ltac ElimOrEq := + match goal with + | |- (?x = ?y) \/ _ -> _ => + let H := fresh in + (intro H; elim H; clear H; + [intro H; rewrite <- H; clear H | ElimOrEq]) + | |- False -> _ => + let H := fresh in (intro H; contradiction) + end. + +Ltac OrEq := + match goal with + | |- (?x = ?x) \/ _ => left; reflexivity + | |- (?x = ?y) \/ _ => right; OrEq + | |- False => fail + end. + +Ltac NotOrEq := + match goal with + | |- (?x = ?y) \/ _ -> False => + let H := fresh in ( + intro H; elim H; clear H; [intro; discriminate | NotOrEq]) + | |- False -> False => + contradiction + end. + +Lemma index_int_callee_save_pos: + forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. +Qed. + +Lemma index_float_callee_save_pos: + forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. +Qed. + +Lemma index_int_callee_save_pos2: + forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_float_callee_save_pos2: + forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_int_callee_save_inj: + forall r1 r2, + In r1 int_callee_save_regs -> + In r2 int_callee_save_regs -> + r1 <> r2 -> + index_int_callee_save r1 <> index_int_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; + intros; congruence. +Qed. + +Lemma index_float_callee_save_inj: + forall r1 r2, + In r1 float_callee_save_regs -> + In r2 float_callee_save_regs -> + r1 <> r2 -> + index_float_callee_save r1 <> index_float_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; + intros; congruence. +Qed. + +(** The following lemmas show that + (temporaries, destroyed at call, integer callee-save, float callee-save) + is a partition of the set of machine registers. *) + +Lemma int_float_callee_save_disjoint: + list_disjoint int_callee_save_regs float_callee_save_regs. +Proof. + red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. +Qed. + +Lemma register_classification: + forall r, + (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ + (In r int_callee_save_regs \/ In r float_callee_save_regs). +Proof. + destruct r; + try (left; left; simpl; OrEq); + try (left; right; simpl; OrEq); + try (right; left; simpl; OrEq); + try (right; right; simpl; OrEq). +Qed. + +Lemma int_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r int_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma float_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r float_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma int_callee_save_type: + forall r, In r int_callee_save_regs -> mreg_type r = Tint. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Lemma float_callee_save_type: + forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Ltac NoRepet := + match goal with + | |- list_norepet nil => + apply list_norepet_nil + | |- list_norepet (?a :: ?b) => + apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] + end. + +Lemma int_callee_save_norepet: + list_norepet int_callee_save_regs. +Proof. + unfold int_callee_save_regs; NoRepet. +Qed. + +Lemma float_callee_save_norepet: + list_norepet float_callee_save_regs. +Proof. + unfold float_callee_save_regs; NoRepet. +Qed. + +(** * Acceptable locations for register allocation *) + +(** The following predicate describes the locations that can be assigned + to an RTL pseudo-register during register allocation: a non-temporary + machine register or a [Local] stack slot are acceptable. *) + +Definition loc_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Local ofs ty) => ofs >= 0 + | S (Incoming _ _) => False + | S (Outgoing _ _) => False + end. + +Definition locs_acceptable (ll: list loc) : Prop := + forall l, In l ll -> loc_acceptable l. + +Lemma temporaries_not_acceptable: + forall l, loc_acceptable l -> Loc.notin l temporaries. +Proof. + unfold loc_acceptable; destruct l. + simpl. intuition congruence. + destruct s; try contradiction. + intro. simpl. tauto. +Qed. +Hint Resolve temporaries_not_acceptable: locs. + +Lemma locs_acceptable_disj_temporaries: + forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. +Proof. + intros. apply Loc.notin_disjoint. intros. + apply temporaries_not_acceptable. auto. +Qed. + +Lemma loc_acceptable_noteq_diff: + forall l1 l2, + loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2. +Proof. + unfold loc_acceptable, Loc.diff; destruct l1; destruct l2; + try (destruct s); try (destruct s0); intros; auto; try congruence. + case (zeq z z0); intro. + compare t t0; intro. + subst z0; subst t0; tauto. + tauto. tauto. + contradiction. contradiction. +Qed. + +Lemma loc_acceptable_notin_notin: + forall r ll, + loc_acceptable r -> + ~(In r ll) -> Loc.notin r ll. +Proof. + induction ll; simpl; intros. + auto. + split. apply loc_acceptable_noteq_diff. assumption. + apply sym_not_equal. tauto. + apply IHll. assumption. tauto. +Qed. + +(** * 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 PowerPC compiler, we + implement the standard conventions defined in the PowerPC application + binary interface. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R0] or [F0], 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) : mreg := + match s.(sig_res) with + | None => R0 + | Some Tint => R0 + | Some Tfloat => F0 + end. + +(** The result location has the type stated in the signature. *) + +Lemma loc_result_type: + forall sig, + mreg_type (loc_result sig) = + match sig.(sig_res) with None => Tint | Some ty => ty end. +Proof. + intros; unfold loc_result. + destruct (sig_res sig). + destruct t; reflexivity. + reflexivity. +Qed. + +(** The result location is acceptable. *) + +Lemma loc_result_acceptable: + forall sig, loc_acceptable (R (loc_result sig)). +Proof. + intros. unfold loc_acceptable. red. + unfold loc_result. destruct (sig_res sig). + destruct t; simpl; NotOrEq. + simpl; NotOrEq. +Qed. + +(** The result location is a caller-save register. *) + +Lemma loc_result_caller_save: + forall (s: signature), In (R (loc_result s)) destroyed_at_call. +Proof. + intros; unfold loc_result. + destruct (sig_res s). + destruct t; simpl; OrEq. + simpl; OrEq. +Qed. + +(** The result location is not a callee-save register. *) + +Lemma loc_result_not_callee_save: + forall (s: signature), + ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs). +Proof. + intros. generalize (loc_result_caller_save s). + generalize (int_callee_save_not_destroyed (loc_result s)). + generalize (float_callee_save_not_destroyed (loc_result s)). + tauto. +Qed. + +(** ** Location of function arguments *) + +(** We use the following calling conventions, adapted from the ARM ABI: +- The first 4 integer arguments are passed in registers [R0] to [R3]. +- The first 2 float arguments are passed in registers [F0] and [F1]. +- Each float argument passed in a float register ``consumes'' two + integer arguments. +- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively + assigned (1 word for an integer argument, 2 words for a float), + starting at word offset 0. + +These conventions are somewhat baroque, but they are mandated by the ABI. +*) + +Fixpoint loc_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : list loc := + match tyl with + | nil => nil + | Tint :: tys => + match iregl with + | nil => + S (Outgoing ofs Tint) :: loc_arguments_rec tys nil fregl (ofs + 1) + | ireg :: iregs => + R ireg :: loc_arguments_rec tys iregs fregl ofs + end + | Tfloat :: tys => + match fregl with + | nil => + S (Outgoing ofs Tfloat) :: + loc_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => + match iregl with + | nil => + S (Outgoing ofs Tfloat) :: + loc_arguments_rec tys nil fregl (ofs + 2) + | ireg :: nil => + R freg :: + loc_arguments_rec tys nil fregs (ofs + 1) + | ireg1 :: ireg2 :: iregs => + R freg :: + loc_arguments_rec tys iregs fregs ofs + end + end + end. + +Definition int_param_regs := + R0 :: R1 :: R2 :: R3 :: nil. +Definition float_param_regs := + F0 :: F1 :: nil. + +(** [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 loc := + loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : Z := + match tyl with + | nil => ofs + | Tint :: tys => + match iregl with + | nil => size_arguments_rec tys nil fregl (ofs + 1) + | ireg :: iregs => size_arguments_rec tys iregs fregl ofs + end + | Tfloat :: tys => + match fregl with + | nil => + size_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => + match iregl with + | nil => + size_arguments_rec tys nil fregl (ofs + 2) + | ireg :: nil => + size_arguments_rec tys nil fregs (ofs + 1) + | ireg1 :: ireg2 :: iregs => + size_arguments_rec tys iregs fregs ofs + end + end + end. + +Definition size_arguments (s: signature) : Z := + size_arguments_rec s.(sig_args) int_param_regs float_param_regs 0. + +(** A tail-call is possible for a signature if the corresponding + arguments are all passed in registers. *) + +Definition tailcall_possible (s: signature) : Prop := + forall l, In l (loc_arguments s) -> + match l with R _ => True | S _ => False end. + +(** 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 => ~(In l temporaries) + | S (Outgoing ofs ty) => ofs >= 0 + | _ => False + end. + +Remark loc_arguments_rec_charact: + forall tyl iregl fregl ofs l, + In l (loc_arguments_rec tyl iregl fregl ofs) -> + match l with + | R r => In r iregl \/ In r fregl + | S (Outgoing ofs' ty) => ofs' >= ofs + | S _ => False + end. +Proof. + induction tyl; simpl loc_arguments_rec; intros. + elim H. + destruct a. + destruct iregl; elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. simpl; intuition. + destruct fregl. + elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + destruct iregl. + elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + destruct iregl. + elim H; intro. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. + intros [A|B]. elim A. auto with coqlib. + destruct s; auto. omega. + elim H; intro. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. + intros [A|B]; auto with coqlib. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (r: loc), + In r (loc_arguments s) -> loc_argument_acceptable r. +Proof. + unfold loc_arguments; intros. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct r. + intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. + simpl. unfold not. ElimOrEq; NotOrEq. + destruct s0; try contradiction. + simpl. omega. +Qed. +Hint Resolve loc_arguments_acceptable: locs. + +(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) + +Remark loc_arguments_rec_notin_reg: + forall tyl iregl fregl ofs r, + ~(In r iregl) -> ~(In r fregl) -> + Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl. auto. + simpl in H. split. apply sym_not_equal. tauto. + apply IHtyl. tauto. tauto. + destruct fregl; simpl. auto. simpl in H0. + destruct iregl; simpl. auto. + destruct iregl; simpl. + split. apply sym_not_equal. tauto. apply IHtyl. hnf. tauto. tauto. + split. apply sym_not_equal. tauto. apply IHtyl. + red; intro. apply H. auto with coqlib. tauto. +Qed. + +Remark loc_arguments_rec_notin_local: + forall tyl iregl fregl ofs ofs0 ty0, + Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; auto. + destruct fregl; simpl; auto. + destruct iregl; simpl; auto. + destruct iregl; simpl; auto. +Qed. + +Remark loc_arguments_rec_notin_outgoing: + forall tyl iregl fregl ofs ofs0 ty0, + ofs0 + typesize ty0 <= ofs -> + Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl. + split. omega. eapply IHtyl. omega. + auto. + destruct fregl; simpl. + split. omega. eapply IHtyl. omega. + destruct iregl; simpl. + split. omega. eapply IHtyl. omega. + destruct iregl; simpl. + split; auto. eapply IHtyl. omega. + split; auto. +Qed. + +Lemma loc_arguments_norepet: + forall (s: signature), Loc.norepet (loc_arguments s). +Proof. + assert (forall tyl iregl fregl ofs, + list_norepet iregl -> + list_norepet fregl -> + list_disjoint iregl fregl -> + Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). + induction tyl; simpl; intros. + constructor. + destruct a. + destruct iregl; constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + apply loc_arguments_rec_notin_reg. inversion H. auto. + apply list_disjoint_notin with (m :: iregl); auto with coqlib. + apply IHtyl. inv H; auto. auto. + eapply list_disjoint_cons_left; eauto. + + destruct fregl. constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + destruct iregl. constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + destruct iregl; constructor. + apply loc_arguments_rec_notin_reg. + red; intro. apply (H1 m m). auto with coqlib. auto with coqlib. auto. + inv H0; auto. + apply IHtyl. constructor. inv H0; auto. + red; intros. elim H2. + apply loc_arguments_rec_notin_reg. + red; intros. elim (H1 m m); auto with coqlib. + inv H0; auto. + apply IHtyl. inv H. inv H5. auto. inv H0; auto. + red; intros. apply H1; auto with coqlib. + + intro. unfold loc_arguments. apply H. + unfold int_param_regs. NoRepet. + unfold float_param_regs. NoRepet. + red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. +Qed. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark size_arguments_rec_above: + forall tyl iregl fregl ofs0, + ofs0 <= size_arguments_rec tyl iregl fregl ofs0. +Proof. + induction tyl; simpl; intros. + omega. + destruct a. + destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. auto. + destruct fregl. apply Zle_trans with (ofs0 + 2); auto; omega. + destruct iregl. apply Zle_trans with (ofs0 + 2); auto; omega. + destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. + auto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros; unfold size_arguments. apply Zle_ge. + apply size_arguments_rec_above. +Qed. + +Lemma loc_arguments_bounded: + forall (s: signature) (ofs: Z) (ty: typ), + In (S (Outgoing ofs ty)) (loc_arguments s) -> + ofs + typesize ty <= size_arguments s. +Proof. + intros. + assert (forall tyl iregl fregl ofs0, + In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> + ofs + typesize ty <= size_arguments_rec tyl iregl fregl ofs0). + induction tyl; simpl; intros. + elim H0. + destruct a. destruct iregl; elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + discriminate. auto. + destruct fregl. elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + destruct iregl. elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + destruct iregl. + elim H0; intro. inv H1. auto. + elim H0; intro. inv H1. auto. + + unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto. +Qed. + +(** Temporary registers do not overlap with argument locations. *) + +Lemma loc_arguments_not_temporaries: + forall sig, Loc.disjoint (loc_arguments sig) temporaries. +Proof. + intros; red; intros x1 x2 H. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct x1. + intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). + destruct s; try contradiction. intro. + simpl; ElimOrEq; auto. +Qed. +Hint Resolve loc_arguments_not_temporaries: locs. + +(** Argument registers are caller-save. *) + +Lemma arguments_caller_save: + forall sig r, + In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call. +Proof. + unfold loc_arguments; intros. + elim (loc_arguments_rec_charact _ _ _ _ _ H); simpl. + ElimOrEq; intuition. + ElimOrEq; intuition. +Qed. + +(** Callee-save registers do not overlap with argument locations. *) + +Lemma arguments_not_preserved: + forall sig l, + Loc.notin l destroyed_at_call -> loc_acceptable l -> + Loc.notin l (loc_arguments sig). +Proof. + intros. unfold loc_arguments. destruct l. + apply loc_arguments_rec_notin_reg. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + destruct s; simpl in H0; try contradiction. + apply loc_arguments_rec_notin_local. +Qed. +Hint Resolve arguments_not_preserved: locs. + +(** Argument locations agree in number with the function signature. *) + +Lemma loc_arguments_length: + forall sig, + List.length (loc_arguments sig) = List.length sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; decEq; auto. + destruct fregl; simpl; decEq; auto. + destruct iregl; simpl. decEq; auto. + destruct iregl; simpl; decEq; auto. + + intros. unfold loc_arguments. auto. +Qed. + +(** Argument locations agree in types with the function signature. *) + +Lemma loc_arguments_type: + forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + (forall r, In r iregl -> mreg_type r = Tint) -> + (forall r, In r fregl -> mreg_type r = Tfloat) -> + List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; f_equal; eauto with coqlib. + destruct fregl; simpl. + f_equal; eauto with coqlib. + destruct iregl; simpl. + f_equal; eauto with coqlib. + destruct iregl; simpl; f_equal; eauto with coqlib. + apply IHtyl. simpl; tauto. auto with coqlib. + apply IHtyl. auto with coqlib. auto with coqlib. + + intros. unfold loc_arguments. apply H. + intro; simpl. ElimOrEq; reflexivity. + intro; simpl. ElimOrEq; reflexivity. +Qed. + +(** There is no partial overlap between an argument location and an + acceptable location: they are either identical or disjoint. *) + +Lemma no_overlap_arguments: + forall args sg, + locs_acceptable args -> + Loc.no_overlap args (loc_arguments sg). +Proof. + unfold Loc.no_overlap; intros. + generalize (H r H0). + generalize (loc_arguments_acceptable _ _ H1). + destruct s; destruct r; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; auto. + intros. right. auto. + destruct s; try tauto. destruct s0; tauto. +Qed. + +(** Decide whether a tailcall is possible. *) + +Definition tailcall_is_possible (sg: signature) : bool := + let fix tcisp (l: list loc) := + match l with + | nil => true + | R _ :: l' => tcisp l' + | S _ :: l' => false + end + in tcisp (loc_arguments sg). + +Lemma tailcall_is_possible_correct: + forall s, tailcall_is_possible s = true -> tailcall_possible s. +Proof. + intro s. unfold tailcall_is_possible, tailcall_possible. + generalize (loc_arguments s). induction l; simpl; intros. + elim H0. + destruct a. + destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. +Qed. + +(** ** Location of function parameters *) + +(** A function finds the values of its parameter in the same locations + where its caller stored them, except that the stack-allocated arguments, + viewed as [Outgoing] slots by the caller, are accessed via [Incoming] + slots (at the same offsets and types) in the callee. *) + +Definition parameter_of_argument (l: loc) : loc := + match l with + | S (Outgoing n ty) => S (Incoming n ty) + | _ => l + end. + +Definition loc_parameters (s: signature) := + List.map parameter_of_argument (loc_arguments s). + +Lemma loc_parameters_type: + forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). +Proof. + intros. unfold loc_parameters. + rewrite list_map_compose. + rewrite <- loc_arguments_type. + apply list_map_exten. + intros. destruct x; simpl. auto. + destruct s; reflexivity. +Qed. + +Lemma loc_parameters_length: + forall sg, List.length (loc_parameters sg) = List.length sg.(sig_args). +Proof. + intros. unfold loc_parameters. rewrite list_length_map. + apply loc_arguments_length. +Qed. + +Lemma loc_parameters_not_temporaries: + forall sig, Loc.disjoint (loc_parameters sig) temporaries. +Proof. + intro; red; intros. + unfold loc_parameters in H. + elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. + generalize (loc_arguments_not_temporaries sig y x2 IN H0). + subst x1. destruct x2. + destruct y; simpl. auto. destruct s; auto. + byContradiction. generalize H0. simpl. NotOrEq. +Qed. + +Lemma no_overlap_parameters: + forall params sg, + locs_acceptable params -> + Loc.no_overlap (loc_parameters sg) params. +Proof. + unfold Loc.no_overlap; intros. + unfold loc_parameters in H0. + elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. + rewrite EQ. + generalize (loc_arguments_acceptable _ _ IN). + generalize (H s H1). + destruct s; destruct t; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; simpl; auto. + intros; right; auto. + destruct s; try tauto. destruct s0; try tauto. + intros; simpl. tauto. +Qed. + +(** ** Location of argument and result for dynamic memory allocation *) + +Definition loc_alloc_argument := R0. +Definition loc_alloc_result := R0. diff --git a/arm/linux/Stacklayout.v b/arm/linux/Stacklayout.v new file mode 100644 index 0000000..dd3c6a1 --- /dev/null +++ b/arm/linux/Stacklayout.v @@ -0,0 +1,79 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import Bounds. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- Space for outgoing arguments to function calls. +- Local stack slots of integer type. +- Saved values of integer callee-save registers used by the function. +- One word of padding, if necessary to align the following data + on a 8-byte boundary. +- Local stack slots of float type. +- Saved values of float callee-save registers used by the function. +- Saved return address into caller. +- Pointer to activation record of the caller. +- Space for the stack-allocated data declared in Cminor. + +To facilitate some of the proofs, the Cminor stack-allocated data +starts at offset 0; the preceding areas in the activation record +therefore have negative offsets. This part (with negative offsets) +is called the ``frame'', by opposition with the ``Cminor stack data'' +which is the part with positive offsets. + +The [frame_env] compilation environment records the positions of +the boundaries between areas in the frame part. +*) + +Definition fe_ofs_arg := 0. + +Record frame_env : Set := mk_frame_env { + fe_size: Z; + fe_ofs_link: Z; + fe_ofs_retaddr: Z; + fe_ofs_int_local: Z; + fe_ofs_int_callee_save: Z; + fe_num_int_callee_save: Z; + fe_ofs_float_local: Z; + fe_ofs_float_callee_save: Z; + fe_num_float_callee_save: Z +}. + +(** Computation of the frame environment from the bounds of the current + function. *) + +Definition make_env (b: bounds) := + let oil := 4 * b.(bound_outgoing) in (* integer locals *) + let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) + let oendi := oics + 4 * b.(bound_int_callee_save) in + let ofl := align oendi 8 in (* float locals *) + let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) + let ora := ofcs + 8 * b.(bound_float_callee_save) in (* retaddr *) + let olink := ora + 4 in (* back link *) + let sz := olink + 4 in (* total frame size *) + mk_frame_env sz olink ora + oil oics b.(bound_int_callee_save) + ofl ofcs b.(bound_float_callee_save). + + +Remark align_float_part: + forall b, + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= + align (4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. +Proof. + intros. apply align_le. omega. +Qed. + |